diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,34 +1,164 @@ -0.1: 17 May 2011 - * initial preview release +0.5: 9 March 2012 -0.1.1: 18 May 2011 - * minor documentation fixes - * link to new website + * New features: -0.2: 3 June 2011 + - '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: - + 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 + + '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: - + opacity attribute - + support for path clipping - * New modules: - + Diagrams.BoundingBox + + Completely new and improved polygon generation API + + Cubic splines + + User-controllable path fill rules - * Fixes and updates: - + withBounds now properly uses the new bounds instead of just combining - them with the old + * Bug fixes: + + fix incorrect corner case in arc generation + + fix incorrect reverseTrail function + 0.3: 18 June 2011 * New features: @@ -48,31 +178,34 @@ * Bug fixes: + Issue 32 (mempty not behaving correctly within concatenations) -0.4: 23 October 2011 +0.2: 3 June 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' + + 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 - + Completely new and improved polygon generation API - + Cubic splines - + User-controllable path fill rules + * New modules: + + Diagrams.BoundingBox - * Bug fixes: + * Fixes and updates: + + withBounds now properly uses the new bounds instead of just combining + them with the old - + fix incorrect corner case in arc generation - + fix incorrect reverseTrail function +0.1.1: 18 May 2011 + * minor documentation fixes + * link to new website -0.4.0.1: 30 October 2011 +0.1: 17 May 2011 + * initial preview release - * bump data-default dependency to allow version 0.3 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,9 @@ -Copyright (c) 2011 diagrams-lib team: +Copyright (c) 2011-2012 diagrams-lib team: + Peter Hall Claude Heiland-Allen + Ian Ross + Michael Sloan Kanchalai Suveepattananont Scott Walck Ryan Yates diff --git a/README b/README --- a/README +++ b/README @@ -7,11 +7,3 @@ instructions, tutorials, a user manual, a gallery of example images, and links to the mailing list, IRC channel, developer wiki and bug tracker. - -The source repository is mirrored on both patch-tag (darcs) and github -(git): - - http://patch-tag.com/r/byorgey/diagrams-lib - https://github.com/byorgey/diagrams-lib - -Patches/pull requests welcome in either place. 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.4.0.1 +Version: 0.5 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 @@ -17,7 +17,7 @@ Build-type: Simple Cabal-version: >=1.6 Extra-source-files: CHANGES, README -Tested-with: GHC == 6.12.3, GHC >= 7.0.2 && <= 7.0.3, GHC == 7.2.1 +Tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.1 Source-repository head type: darcs location: http://patch-tag.com/r/byorgey/diagrams-lib @@ -27,6 +27,7 @@ Diagrams.Align, Diagrams.Combinators, Diagrams.Attributes, + Diagrams.Points, Diagrams.Segment, Diagrams.Path, Diagrams.CubicSpline, @@ -52,18 +53,20 @@ Diagrams.TwoD.Adjust, Diagrams.ThreeD.Types, Diagrams.ThreeD.Shapes, + Diagrams.Animation, + Diagrams.Animation.Active, Diagrams.Util, Diagrams.Backend.Show - Build-depends: base >= 4.2 && < 4.5, + Build-depends: base >= 4.2 && < 4.6, containers >= 0.3 && < 0.5, - array >= 0.3 && < 0.4, + array >= 0.3 && < 0.5, semigroups >= 0.3.4 && < 0.9, - diagrams-core >= 0.4 && < 0.5, - vector-space >= 0.7.7 && < 0.8, + diagrams-core >= 0.5 && < 0.6, + active >= 0.1 && < 0.2, + vector-space >= 0.7.7 && < 0.9, NumInstances >= 1.0 && < 1.1, - colour >= 2.3.1 && < 2.4, + colour >= 2.3.2 && < 2.4, data-default >= 0.2 && < 0.4, pretty >= 1.0.1.2 && < 1.2, - newtype >= 0.2 && < 0.3, - tau >= 6.28 + newtype >= 0.2 && < 0.3 Hs-source-dirs: src diff --git a/src/Diagrams/Align.hs b/src/Diagrams/Align.hs --- a/src/Diagrams/Align.hs +++ b/src/Diagrams/Align.hs @@ -10,16 +10,25 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- General tools for alignment. Any boundable object with a local --- origin can be aligned; this includes diagrams, of course, but it also --- includes paths. +-- The /alignment/ of an object refers to the position of its local +-- origin with respect to its envelope. This module defines the +-- 'Alignable' class for things which can be aligned, as well as a +-- default implementation in terms of 'HasOrigin' and 'Enveloped', +-- along with several utility methods for alignment. -- ----------------------------------------------------------------------------- module Diagrams.Align - ( -- * Generic alignment functions - align, alignBy + ( -- * Alignable class + + Alignable(..) + , alignByDefault + + -- * General alignment functions + + , align , center + ) where import Graphics.Rendering.Diagrams @@ -27,28 +36,55 @@ import Data.VectorSpace import Data.AffineSpace (alerp) --- | @align v@ aligns a boundable object along the edge in the --- direction of @v@. That is, it moves the local origin in the --- direction of @v@ until it is on the boundary. (Note that if the --- local origin is outside the boundary to begin, it may have to --- move \"backwards\".) -align :: (HasOrigin a, Boundable a) => V a -> a -> a -align v a = moveOriginTo (boundary v a) a +import qualified Data.Set as S +import qualified Data.Map as M +-- | Class of things which can be aligned. +class Alignable a where --- | @align v d a@ moves the origin of @a@ along the vector @v@. If @d --- = 1@, the origin is moved to the boundary in the direction of --- @v@; if @d = -1@, it moves to the boundary in the direction of --- the negation of @v@. Other values of @d@ interpolate linearly --- (so for example, @d = 0@ centers the origin along the direction --- of @v@). -alignBy :: (HasOrigin a, Boundable a, Num (Scalar (V a))) - => V a -> Scalar (V a) -> a -> a -alignBy v d a = moveOriginTo (alerp (boundary (negateV v) a) - (boundary v a) + -- | @alignBy v d a@ moves the origin of @a@ along the vector + -- @v@. If @d = 1@, the origin is moved to the edge of the + -- envelope in the direction of @v@; if @d = -1@, it moves to the + -- edge of the envelope in the direction of the negation of @v@. + -- Other values of @d@ interpolate linearly (so for example, @d = + -- 0@ centers the origin along the direction of @v@). + alignBy :: V a -> Scalar (V a) -> a -> a + +-- | Default implementation of 'alignBy' for types with 'HasOrigin' +-- and 'Enveloped' instances. +alignByDefault :: (HasOrigin a, Enveloped a, Num (Scalar (V a))) + => V a -> Scalar (V a) -> a -> a +alignByDefault v d a = moveOriginTo (alerp (envelopeP (negateV v) a) + (envelopeP v a) ((d + 1) / 2)) a --- | @center v@ centers a boundable object along the direction of @v@. -center :: (HasOrigin a, Boundable a) => V a -> a -> a +instance (InnerSpace v, OrderedField (Scalar v)) => Alignable (Envelope v) where + alignBy = alignByDefault + +instance (Enveloped b, HasOrigin b) => Alignable [b] where + alignBy = alignByDefault + +instance (Enveloped b, HasOrigin b, Ord b) => Alignable (S.Set b) where + alignBy = alignByDefault + +instance (Enveloped b, HasOrigin b) => Alignable (M.Map k b) where + alignBy = alignByDefault + +instance ( HasLinearMap v, InnerSpace v, OrderedField (Scalar v) + , Monoid' m + ) => Alignable (QDiagram b v m) where + alignBy = alignByDefault + +-- | @align v@ aligns an enveloped object along the edge in the +-- direction of @v@. That is, it moves the local origin in the +-- direction of @v@ until it is on the edge of the envelope. (Note +-- that if the local origin is outside the envelope to begin with, +-- it may have to move \"backwards\".) +align :: (Alignable a, Num (Scalar (V a))) => V a -> a -> a +align v = alignBy v 1 + +-- | @center v@ centers an enveloped object along the direction of +-- @v@. +center :: (Alignable a, Num (Scalar (V a))) => V a -> a -> a center v = alignBy v 0 diff --git a/src/Diagrams/Animation.hs b/src/Diagrams/Animation.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Animation.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE TypeFamilies + , FlexibleContexts + #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Animation +-- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- An animation is a time-varying diagram, together with start and end +-- times. Most of the tools for working with animations can actually +-- be found in the @active@ package, which defines the 'Active' type. +-- +-- XXX more documentation and examples should go here +-- +----------------------------------------------------------------------------- + +module Diagrams.Animation + ( -- * Types for animations + QAnimation + , Animation + + -- * Animation combinators and tools + -- $animComb + , animEnvelope, animEnvelope' + + , animRect, animRect' + + ) where + +import Graphics.Rendering.Diagrams + +import Diagrams.Combinators +import Diagrams.Animation.Active () +import Diagrams.BoundingBox +import Diagrams.TwoD.Shapes +import Diagrams.TwoD.Types +import Diagrams.Path + +import Data.Active +import Data.Semigroup + +import Data.VectorSpace + +import Control.Applicative ((<$>)) + +-- | A value of type @QAnimation b v m@ is an animation (a +-- time-varying diagram with start and end times) that can be +-- rendered by backspace @b@, with vector space @v@ and monoidal +-- annotations of type @m@. +type QAnimation b v m = Active (QDiagram b v m) + +-- | A value of type @Animation b v@ is an animation (a time-varying +-- diagram with start and end times) in vector space @v@ that can be +-- rendered by backspace @b@. +-- +-- Note that @Animation@ is actually a synonym for @QAnimation@ +-- where the type of the monoidal annotations has been fixed to +-- 'Any' (the default). +type Animation b v = QAnimation b v Any + +-- $animComb +-- Most combinators for working with animations are to be found in the +-- @active@ package, which defines the 'Active' type. This module +-- defines just a few combinators specifically for working with +-- animated diagrams. + +-- It would be cool to have a variant of animEnvelope that tries to do +-- some sort of smart adaptive sampling to get good results more +-- quickly. One could also imagine trying to use some sort of +-- automatic differentiation but that probably wouldn't work in all +-- cases we want to handle. + +-- | Automatically assign fixed a envelope to the entirety of an +-- animation by sampling the envelope at a number of points in time +-- and taking the union of all the sampled envelopes to form the +-- \"hull\". This hull is then used uniformly throughout the +-- animation. +-- +-- This is useful when you have an animation that grows and shrinks +-- in size or shape over time, but you want it to take up a fixed +-- amount of space, /e.g./ so that the final rendered movie does not +-- zoom in and out, or so that it occupies a fixed location with +-- respect to another animation, when combining animations with +-- something like '|||'. +-- +-- By default, 30 samples per time unit are used; to adjust this +-- number see 'animEnvelope''. +-- +-- See also 'animRect' for help constructing a background to go +-- behind an animation. +animEnvelope :: (Backend b v, OrderedField (Scalar v), InnerSpace v, Monoid' m) + => QAnimation b v m -> QAnimation b v m +animEnvelope = animEnvelope' 30 + +-- | Like 'animEnvelope', but with an adjustible sample rate. The first +-- parameter is the number of samples per time unit to use. Lower +-- rates will be faster but less accurate; higher rates are more +-- accurate but slower. +animEnvelope' :: (Backend b v, OrderedField (Scalar v), InnerSpace v, Monoid' m) + => Rational -> QAnimation b v m -> QAnimation b v m +animEnvelope' r a = withEnvelope (simulate r a) <$> a + +-- | @animRect@ works similarly to 'animEnvelope' for 2D diagrams, but +-- instead of adjusting the envelope, simply returns the smallest +-- bounding rectangle which encloses the entire animation. Useful +-- for /e.g./ creating a background to go behind an animation. +-- +-- Uses 30 samples per time unit by default; to adjust this number +-- see 'animRect''. +animRect :: (PathLike p, Enveloped p, Transformable p, V p ~ R2) + => QAnimation b R2 m -> p +animRect = animRect' 30 + +-- | Like 'animRect', but with an adjustible sample rate. The first +-- parameter is the number of samples per time unit to use. Lower +-- rates will be faster but less accurate; higher rates are more +-- accurate but slower. +animRect' :: (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 diff --git a/src/Diagrams/Animation/Active.hs b/src/Diagrams/Animation/Active.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Animation/Active.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE TypeFamilies + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Animation.Active +-- Copyright : (c) 2011 Brent Yorgey +-- License : BSD-style (see LICENSE) +-- Maintainer : byorgey@cis.upenn.edu +-- +-- A few utilities and class instances for 'Active' (from the @active@ +-- package). In particular, this module defines +-- +-- * An instance of 'V' for 'Active': @'V' ('Active' a) = 'V' a@ +-- +-- * 'HasOrigin', 'Transformable', and 'HasStyle' instances for +-- 'Active' which all work pointwise. +-- +-- * A 'PathLike' instance for @'Active' p@ where @p@ is also +-- 'PathLike', which simply lifts a pathlike thing to a constant +-- active value. +-- +-- * A 'Juxtaposable' instance for @'Active' a@ where @a@ is also +-- 'Juxtaposable'. An active value can be juxtaposed against +-- another by doing the juxtaposition pointwise over time. The +-- era of @juxtapose v a1 a2@ will be the same as the era of @a2@, +-- unless @a2@ is constant, in which case it will be the era of +-- @a1@. (Note that @juxtapose v a1 a2@ and @liftA2 (juxtapose v) +-- a1 a2@ therefore have different semantics: the second is an +-- active value whose era is the /combination/ of the eras of @a1@ +-- and @a2@). +-- +-- * An 'Alignable' instance for @'Active' a@ where @a@ is also +-- 'Alignable'; the active value is aligned pointwise over time. + +----------------------------------------------------------------------------- + +module Diagrams.Animation.Active where + +import Graphics.Rendering.Diagrams +import Control.Applicative ((<$>), pure) + +import Diagrams.Align +import Diagrams.Path + +import Data.Active + +type instance V (Active a) = V a + +-- Yes, these are all orphan instances. Get over it. We don't want to +-- put them in the 'active' package because 'active' is supposed to be +-- generally useful and shouldn't depend on diagrams. We'd also +-- rather not put them in diagrams-core so that diagrams-core doesn't +-- have to depend on active. + +instance HasOrigin a => HasOrigin (Active a) where + moveOriginTo = fmap . moveOriginTo + +instance Transformable a => Transformable (Active a) where + transform = fmap . transform + +instance HasStyle a => HasStyle (Active a) where + applyStyle = fmap . applyStyle + +instance PathLike p => PathLike (Active p) where + pathLike st cl segs = pure (pathLike st cl segs) + +-- | An active value can be juxtaposed against another by doing the +-- juxtaposition pointwise over time. The era of @juxtapose v a1 +-- a2@ will be the same as the era of @a2@, unless @a2@ is constant, +-- in which case it will be the era of @a1@. (Note that @juxtapose +-- v a1 a2@ and @liftA2 (juxtapose v) a1 a2@ therefore have +-- different semantics: the second is an active value whose era is +-- the /combination/ of the eras of @a1@ and @a2@). +instance Juxtaposable a => Juxtaposable (Active a) where + + juxtapose v a1 a2 = + onActive -- a1 + (\c1 -> -- if a1 is constant, just juxtapose a2 pointwise with its value + juxtapose v c1 <$> a2 + ) + -- if a1 is dynamic... + (onDynamic $ \s1 e1 d1 -> + onActive -- a2 + (\c2 -> -- if a2 is constant, juxtapose pointwise with a1. Since + -- the result will no longer be constant, the result + -- needs an era: we use a1's. + mkActive s1 e1 (\t -> juxtapose v (d1 t) c2) + ) + + -- otherwise, juxtapose pointwise, without changing a2's era + (onDynamic $ \s2 e2 d2 -> + mkActive s2 e2 (\t -> juxtapose v (d1 t) (d2 t)) + ) + a2 + ) + a1 + +instance Alignable a => Alignable (Active a) where + alignBy v d a = alignBy v d <$> a diff --git a/src/Diagrams/Backend/Show.hs b/src/Diagrams/Backend/Show.hs --- a/src/Diagrams/Backend/Show.hs +++ b/src/Diagrams/Backend/Show.hs @@ -20,11 +20,9 @@ import Diagrams.Prelude -import Diagrams.TwoD.Ellipse - import Data.Basis -import Text.PrettyPrint (Doc, empty, ($+$), parens, hsep, nest) +import Text.PrettyPrint (Doc, empty, ($+$), parens, hsep) import qualified Text.PrettyPrint as PP import Data.List (transpose) @@ -45,7 +43,7 @@ mempty = SR empty (SR d1) `mappend` (SR d2) = SR (d1 $+$ d2) -renderTransf :: forall v. (Num (Scalar v), HasLinearMap v) +renderTransf :: forall v. (Num (Scalar v), HasLinearMap v, Show (Scalar v)) => Transformation v -> Doc renderTransf t = renderMat mat where tr :: v @@ -65,11 +63,6 @@ renderMat :: Show a => [[a]] -> Doc renderMat = PP.vcat . map renderRow . transpose where renderRow = parens . hsep . map (PP.text . show) - -instance Renderable Ellipse ShowBackend where - render _ (Ellipse t) = SR $ PP.text "Ellipse (" $+$ - nest 2 (renderTransf t) $+$ - PP.text ")" instance (Show v, HasLinearMap v) => Renderable (Segment v) ShowBackend where render _ s = SR $ PP.text (show s) diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -2,8 +2,9 @@ , DeriveFunctor , FlexibleContexts , NoMonomorphismRestriction - , TypeFamilies , ScopedTypeVariables + , TypeFamilies + , UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -24,9 +25,13 @@ , fromCorners, fromPoint, fromPoints , boundingBox - -- * Operations on bounding boxes + -- * Queries on bounding boxes + , getCorners, getAllCorners + , boxExtents, boxTransform, boxFit , contains, contains' , inside, inside', outside, outside' + + -- * Operations on bounding boxes , union, intersection, unions, intersections ) where @@ -37,17 +42,19 @@ import Data.Maybe (fromJust) -import Data.VectorSpace (VectorSpace, Scalar, AdditiveGroup, zeroV, negateV) +import Data.VectorSpace +-- (VectorSpace, Scalar, AdditiveGroup, zeroV, negateV, (^+^), (^-^)) import Data.Basis (HasBasis, Basis, decompose, recompose, basisValue) import Data.Data (Data) import Data.Typeable (Typeable) import Graphics.Rendering.Diagrams.Points (Point(..)) -import Graphics.Rendering.Diagrams.Transform (Transformable(..), HasLinearMap) import Graphics.Rendering.Diagrams.HasOrigin (HasOrigin(..)) -import Graphics.Rendering.Diagrams.Bounds (Boundable, boundary) +import Graphics.Rendering.Diagrams.Envelope (Enveloped(..), envelopeP) import Graphics.Rendering.Diagrams.V (V) +import Graphics.Rendering.Diagrams.Transform + (Transformation(..), Transformable(..), HasLinearMap, (<->)) -- | A bounding box is an axis-aligned region determined -- by two points indicating its \"lower\" and \"upper\" corners. @@ -56,20 +63,21 @@ type instance V (BoundingBox v) = v -instance (HasLinearMap v, Transformable v) => Transformable (BoundingBox v) where - transform t (BoundingBox p1 p2) = BoundingBox (transform t p1) - (transform t p2) - instance VectorSpace v => HasOrigin (BoundingBox v) where moveOriginTo p (BoundingBox p1 p2) = BoundingBox (moveOriginTo p p1) (moveOriginTo p p2) +instance ( InnerSpace v, Floating (Scalar v), Ord (Scalar v), AdditiveGroup (Scalar v) + , HasBasis v, Ord (Basis v) + ) => Enveloped (BoundingBox v) where + getEnvelope = getEnvelope . getAllCorners + -- | Create a bounding box from any two opposite corners. fromCorners :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) => Point v -> Point v -> BoundingBox v -fromCorners u v = BoundingBox (toPoint (combineV min u v)) - (toPoint (combineV max u v)) +fromCorners u v = BoundingBox (toPoint (combineP min u v)) + (toPoint (combineP max u v)) -- | Create a degenerate bounding \"box\" containing only a single point. fromPoint @@ -84,24 +92,67 @@ fromPoints = unions . map fromPoint -- | Create a bounding box for any boundable object (such as a diagram or path). -boundingBox :: forall a. (Boundable a, HasBasis (V a), Ord (Basis (V a))) +boundingBox :: forall a. (Enveloped a, HasBasis (V a), Ord (Basis (V a))) => a -> BoundingBox (V a) -boundingBox a = fromJust . fromPoints . map (flip boundary a) $ [id, negateV] <*> units +boundingBox a = fromJust . fromPoints . map (`envelopeP` a) $ [id, negateV] <*> units where units = map (basisValue . 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) + +{- +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) => +-} + +-- | 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) + = map (P . recompose) + -- Enumerate all combinations of selections of lower / higher values. + . mapM (\(b, (x, y)) -> [(b, x), (b, y)]) + . toList $ combineP (,) l u + +-- | Get the size of the bounding box - the vector from the lesser to the greater +-- point. +boxExtents :: (AdditiveGroup v) => BoundingBox v -> v +boxExtents (BoundingBox (P l) (P h)) = h ^-^ l + +-- | 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 + +-- | Transforms a boundable thing to fit within a @BoundingBox@. +boxFit :: (Enveloped a, Transformable a, Ord (Basis (V a))) + => BoundingBox (V a) -> a -> a +boxFit b x = transform (boxTransform (boundingBox x) b) x + -- | 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 (combineV (<=) l p) - && F.and (combineV (<=) p h) +contains (BoundingBox l h) p = 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 (combineV (< ) l p) - && F.and (combineV (< ) p h) +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). @@ -124,32 +175,32 @@ 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 (combineV (<=) uh vh) - && F.and (combineV (>=) ul vl) +inside (BoundingBox ul uh) (BoundingBox vl vh) = F.and (combineP (<=) uh vh) + && F.and (combineP (>=) ul vl) -- | 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 (combineV (< ) uh vh) - && F.and (combineV (> ) ul vl) +inside' (BoundingBox ul uh) (BoundingBox vl vh) = F.and (combineP (< ) uh vh) + && F.and (combineP (> ) ul vl) -- | 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 (combineV (<=) uh vl) - || F.or (combineV (>=) ul vh) +outside (BoundingBox ul uh) (BoundingBox vl vh) = 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 (combineV (< ) uh vl) - || F.or (combineV (> ) ul vh) +outside' (BoundingBox ul uh) (BoundingBox vl vh) = 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 @@ -159,13 +210,13 @@ => BoundingBox v -> BoundingBox v -> Maybe (BoundingBox v) intersection u@(BoundingBox ul uh) v@(BoundingBox vl vh) | u `outside'` v = Nothing - | otherwise = Just (fromCorners (toPoint (combineV max ul vl)) (toPoint (combineV min uh vh))) + | 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 (combineV min ul vl)) (toPoint (combineV max uh vh)) +union (BoundingBox ul uh) (BoundingBox vl vh) = BoundingBox (toPoint (combineP min ul vl)) (toPoint (combineP max uh vh)) -- internals using Map (Basis v) (Scalar v) -- probably paranoia, but decompose might not always @@ -175,12 +226,20 @@ fromVector :: (HasBasis v, Ord (Basis v)) => v -> Map (Basis v) (Scalar v) fromVector = fromList . decompose +toVector :: HasBasis v => Map (Basis v) (Scalar v) -> v +toVector = recompose . toList + toPoint :: HasBasis v => Map (Basis v) (Scalar v) -> Point v -toPoint = P . recompose . toList +toPoint = P . toVector -combineV :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v)) => (Scalar v -> Scalar v -> a) -> Point v -> Point v -> Map (Basis v) a -combineV f (P u) (P v) = combineDefault zeroV zeroV f (fromVector u) (fromVector v) +combineV :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v)) + => (Scalar v -> Scalar v -> a) -> v -> v -> Map (Basis v) a +combineV f u v = combineDefault zeroV zeroV f (fromVector u) (fromVector v) +combineP :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v)) + => (Scalar v -> Scalar v -> a) -> Point v -> Point v -> Map (Basis v) a +combineP f (P u) (P v) = combineV f u v + combineDefault :: Ord k => a -> b -> (a -> b -> c) -> Map k a -> Map k b -> Map k c combineDefault a b f = combine g where @@ -188,7 +247,6 @@ g Nothing (Just y) = f a y g (Just x) Nothing = f x b g (Just x) (Just y) = f x y - combine :: Ord k => (Maybe a -> Maybe b -> c) -> Map k a -> Map k b -> Map k c combine f am bm = fromDistinctAscList $ merge (toAscList am) (toAscList bm) diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -16,14 +16,14 @@ module Diagrams.Combinators ( -- * Unary operations - withBounds + withEnvelope , phantom, strut , pad -- * Binary operations - , beside, besideBounds - , append + , beneath + , beside -- * n-ary operations , appends @@ -36,97 +36,93 @@ import Diagrams.Segment (Segment(..)) import Diagrams.Path -import Diagrams.Align import Diagrams.Util import Data.AdditiveGroup -import Data.AffineSpace ((.-.)) import Data.VectorSpace -import Data.List (foldl') -import Data.Monoid +import Data.Semigroup import Data.Default ------------------------------------------------------------ --- Working with bounds +-- Working with envelopes ------------------------------------------------------------ --- | Use the bounding region from some boundable object as the --- bounding region for a diagram, in place of the diagram's default --- bounding region. -withBounds :: (Backend b (V a), Boundable a, Monoid m) - => a -> AnnDiagram b (V a) m -> AnnDiagram b (V a) m -withBounds = setBounds . getBounds +-- | 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) + => a -> QDiagram b (V a) m -> QDiagram b (V a) m +withEnvelope = setEnvelope . getEnvelope -- | @phantom x@ produces a \"phantom\" diagram, which has the same --- bounding region as @x@ but produces no output. -phantom :: (Backend b (V a), Boundable a, Monoid m) => a -> AnnDiagram b (V a) m -phantom a = mkAD nullPrim (getBounds a) mempty mempty +-- 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 --- | @pad s@ \"pads\" a diagram, expanding its bounding region by a --- factor of @s@ (factors between 0 and 1 can be used to shrink the --- bounding region). Note that the bounding region will expand with --- respect to the local origin, so if the origin is not centered the --- padding may appear \"uneven\". If this is not desired, the --- origin can be centered (using, e.g., 'centerXY' for 2D diagrams) --- before applying @pad@. +-- | @pad s@ \"pads\" a diagram, expanding its envelope by a factor of +-- @s@ (factors between 0 and 1 can be used to shrink the envelope). +-- Note that the envelope will expand with respect to the local +-- origin, so if the origin is not centered the padding may appear +-- \"uneven\". If this is not desired, the origin can be centered +-- (using, e.g., 'centerXY' for 2D diagrams) before applying @pad@. pad :: ( Backend b v , InnerSpace v, OrderedField (Scalar v) - , Monoid m ) - => Scalar v -> AnnDiagram b v m -> AnnDiagram b v m -pad s d = withBounds (d # scale s) d + , Monoid' m ) + => Scalar v -> QDiagram b v m -> QDiagram b v m +pad s d = withEnvelope (d # scale s) d --- | @strut v@ is a diagram which produces no output, but for the --- purposes of alignment and bounding regions 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. +-- | @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. strut :: ( Backend b v, InnerSpace v , OrderedField (Scalar v) - , Monoid m + , Monoid' m ) - => v -> AnnDiagram b v m -strut v = phantom . translate ((-0.5) *^ v) . getBounds $ Linear v + => v -> QDiagram b v m +strut v = phantom . translate ((-0.5) *^ v) . getEnvelope $ Linear v ------------------------------------------------------------ -- Combining two objects ------------------------------------------------------------ --- | Place two bounded, monoidal objects (i.e. diagrams or paths) next --- to each other along the given vector. In particular, place the --- first object so that the vector points from its local origin to --- the local origin of the second object, at a distance so that --- their bounding regions are just tangent. The local origin of the --- new, combined object is at the point of tangency, along the line --- between the old local origins. -beside :: (HasOrigin a, Boundable a, Monoid a) => V a -> a -> a -> a -beside v d1 d2 - = align v d1 <> align (negateV v) d2 --- XXX add picture to above documentation? - --- Note that sending the origin to the point of tangency like this --- means that (beside v) is not associative. We can make it --- associative if we specify that the origin of the new, composed --- diagram is the same as the local origin of the first diagram (or, --- dually, of the second). But then mempty is only a right identity, --- not a left identity. (To be sure, with the current implementation --- mempty is no identity at all!) We could make (beside v) a monoidal --- operation (associative, with mempty as identity) if we always --- center the origin along v after combining. That sounds nice from a --- theoretical point of view but not from a usability point of view... +-- | @beneath@ is just a convenient synonym for @'flip' 'atop'@; that is, +-- @d1 \`beneath\` d2@ is the diagram with @d2@ superimposed on top of +-- @d1@. +beneath :: (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Monoid' m) + => QDiagram b v m -> QDiagram b v m -> QDiagram b v m +beneath = flip atop --- | @besideBounds b v x@ positions @x@ so it is beside the bounding --- region @b@ in the direction of @v@. The origin of the new --- diagram is the origin of the bounding region. -besideBounds :: (HasOrigin a, Boundable a) => Bounds (V a) -> V a -> a -> a -besideBounds b v a - = moveOriginBy (origin .-. boundary v b) (align (negateV v) a) +-- | Place two monoidal objects (/i.e./ diagrams, paths, +-- animations...) next to each other along the given vector. In +-- particular, place the second object so that the vector points +-- from the local origin of the first object to the local origin of +-- the second object, at a distance so that their envelopes are just +-- tangent. The local origin of the new, combined object is the +-- local origin of the first object. +-- +-- Note that @beside v@ is associative, so objects under @beside v@ +-- form a semigroup for any given vector @v@. However, they do +-- /not/ form a monoid, since there is no identity element. 'mempty' +-- is a right identity (@beside v d1 mempty === d1@) but not a left +-- identity (@beside v mempty d1 === d1 # align (negateV v)@). +-- +-- In older versions of diagrams, @beside@ put the local origin of +-- the result at the point of tangency between the two inputs. That +-- semantics can easily be recovered by performing an alignment on +-- the first input before combining. That is, if @beside'@ denotes +-- the old semantics, +-- +-- > beside' v x1 x2 = beside v (x1 # align v) x2 +-- +-- To get something like @beside v x1 x2@ whose local origin is +-- identified with that of @x2@ instead of @x1@, use @beside +-- (negateV v) x2 x1@. +beside :: (Juxtaposable a, Semigroup a) => V a -> a -> a -> a +beside v d1 d2 = d1 <> juxtapose v d1 d2 --- | Like 'beside', but the origin of the final combined object is the --- origin of the first object. See also 'appends'. -append :: (HasOrigin a, Boundable a, Monoid a) => V a -> a -> a -> a -append v d1 d2 = appends d1 [(v,d2)] +-- XXX add picture to above documentation? ------------------------------------------------------------ -- Combining multiple objects @@ -135,15 +131,14 @@ -- | @appends x ys@ appends each of the objects in @ys@ to the object -- @x@ in the corresponding direction. Note that each object in -- @ys@ is positioned beside @x@ /without/ reference to the other --- objects in @ys@, so this is not the same as iterating 'append'. -appends :: (HasOrigin a, Boundable a, Monoid a) => a -> [(V a,a)] -> a -appends d1 apps = d1 <> mconcat (map (uncurry (besideBounds b)) apps) - where b = getBounds d1 +-- objects in @ys@, so this is not the same as iterating 'beside'. +appends :: (Juxtaposable a, Monoid' a) => a -> [(V a,a)] -> a +appends d1 apps = d1 <> mconcat (map (\(v,d) -> juxtapose v d1 d) apps) -- | Position things absolutely: combine a list of objects --- (e.g. diagrams or paths) by assigning them absolute positions in --- the vector space of the combined object. -position :: (HasOrigin a, Monoid a) => [(Point (V a), a)] -> a +-- (e.g. diagrams or paths) by assigning them absolute positions in +-- the vector space of the combined object. +position :: (HasOrigin a, Monoid' a) => [(Point (V a), a)] -> a position = mconcat . map (uncurry moveTo) -- | Combine a list of diagrams (or paths) by using them to @@ -152,7 +147,7 @@ -- trail is placed at the origin. If the trail and list of objects -- have different lengths, the extra tail of the longer one is -- ignored. -decorateTrail :: (HasOrigin a, Monoid a) => Trail (V a) -> [a] -> a +decorateTrail :: (HasOrigin a, Monoid' a) => Trail (V a) -> [a] -> a decorateTrail t = position . zip (trailVertices origin t) -- | Combine a list of diagrams (or paths) by using them to @@ -160,7 +155,7 @@ -- each successive vertex of the path. If the path and list of objects -- have different lengths, the extra tail of the longer one is -- ignored. -decoratePath :: (HasOrigin a, Monoid a) => Path (V a) -> [a] -> a +decoratePath :: (HasOrigin a, Monoid' a) => Path (V a) -> [a] -> a decoratePath p = position . zip (concat $ pathVertices p) -- | Methods for concatenating diagrams. @@ -168,14 +163,14 @@ -- next to one another (possibly with a -- certain distance in between each). The -- distance between successive diagram - -- /boundaries/ will be consistent; the + -- /envelopes/ will be consistent; the -- distance between /origins/ may vary if -- the diagrams are of different sizes. | Distrib -- ^ Distribution: place the local origins of -- diagrams at regular intervals. With -- this method, the distance between -- successive /origins/ will be consistent - -- but the distance between boundaries may + -- but the distance between envelopes may -- not be. Indeed, depending on the amount -- of separation, diagrams may overlap. @@ -189,7 +184,7 @@ -- between successive diagrams -- (default: 0)? When @catMethod = -- Cat@, this is the distance between - -- /boundaries/; when @catMethod = + -- /envelopes/; when @catMethod = -- Distrib@, this is the distance -- between /origins/. , catOptsvProxy__ :: Proxy v @@ -214,24 +209,27 @@ -- | @cat v@ positions a list of objects so that their local origins -- lie along a line in the direction of @v@. Successive objects --- will have their bounding regions just touching. The local origin +-- will have their envelopes just touching. The local origin -- of the result will be the same as the local origin of the first -- object. -- -- See also 'cat'', which takes an extra options record allowing -- certain aspects of the operation to be tweaked. -cat :: (HasOrigin a, Boundable a, Monoid a) => V a -> [a] -> a +cat :: ( Juxtaposable a, Monoid' a, HasOrigin a + , InnerSpace (V a), Floating (Scalar (V a)) + ) + => V a -> [a] -> a cat v = cat' v def -- | Like 'cat', but taking an extra 'CatOpts' arguments allowing the -- user to specify -- -- * The spacing method: catenation (uniform spacing between --- boundaries) or distribution (uniform spacing between local +-- envelopes) or distribution (uniform spacing between local -- origins). The default is catenation. -- -- * The amount of separation between successive diagram --- boundaries/origins (depending on the spacing method). The +-- envelopes/origins (depending on the spacing method). The -- default is 0. -- -- 'CatOpts' is an instance of 'Default', so 'with' may be used for @@ -240,21 +238,14 @@ -- Note that @cat' v with {catMethod = Distrib} === mconcat@ -- (distributing with a separation of 0 is the same as -- superimposing). -cat' :: (HasOrigin a, Boundable a, Monoid a) +cat' :: ( Juxtaposable a, Monoid' a, HasOrigin a + , InnerSpace (V a), Floating (Scalar (V a)) + ) => V a -> CatOpts (V a) -> [a] -> a -cat' _ (CatOpts { catMethod = Cat }) [] = mempty -cat' _ (CatOpts { catMethod = Cat }) [d] = d -cat' v (CatOpts { catMethod = Cat, sep = s }) (x:xs) = - foldl' (\d2 d1 -> - d1 <> (moveOriginBy (origin .-. boundary v d1) - . moveOriginBy (withLength s (negateV v)) - $ d2) - ) - d - ds - where (d:ds) = reverse (x:xs') - xs' = map (align (negateV v)) xs +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) -cat' v (CatOpts { catMethod = Distrib, sep = s }) ds = - decorateTrail (fromOffsets (repeat (withLength s v))) ds +cat' v (CatOpts { catMethod = Distrib, sep = s }) = + decorateTrail . fromOffsets . repeat $ withLength s v -- infinite trail, no problem for Haskell =D diff --git a/src/Diagrams/CubicSpline.hs b/src/Diagrams/CubicSpline.hs --- a/src/Diagrams/CubicSpline.hs +++ b/src/Diagrams/CubicSpline.hs @@ -9,7 +9,12 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- Generic functionality for constructing cubic splines +-- A /cubic spline/ is a smooth, connected sequence of cubic curves +-- passing through a given sequence of points. This module provides +-- the 'cubicSpline' method, which can be used to create closed or +-- open cubic splines from a list of points. For access to the +-- internals of the spline generation algorithm, see +-- "Diagrams.CubicSpline.Internal". -- ----------------------------------------------------------------------------- module Diagrams.CubicSpline @@ -21,11 +26,15 @@ import Diagrams.CubicSpline.Internal import Graphics.Rendering.Diagrams +import Graphics.Rendering.Diagrams.Points + import Diagrams.Segment import Diagrams.Path +import Data.NumInstances () -- for e.g. the Fractional (Double, Double) instance + import Control.Newtype -import Data.Monoid +import Data.Semigroup -- | Construct a spline path-like thing of cubic segments from a list of -- vertices, with the first vertex as the starting point. The first diff --git a/src/Diagrams/CubicSpline/Internal.hs b/src/Diagrams/CubicSpline/Internal.hs --- a/src/Diagrams/CubicSpline/Internal.hs +++ b/src/Diagrams/CubicSpline/Internal.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies , FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.CubicSpline @@ -8,7 +9,10 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- Generic functionality for constructing cubic splines +-- A /cubic spline/ is a smooth, connected sequence of cubic curves +-- passing through a given sequence of points. This module implements +-- a straightforward spline generation algorithm based on solving +-- tridiagonal systems of linear equations. -- ----------------------------------------------------------------------------- module Diagrams.CubicSpline.Internal @@ -21,12 +25,7 @@ , solveCubicSplineCoefficients ) where -import Control.Applicative -import Control.Newtype -import Data.Monoid import Data.List -import Data.VectorSpace -import Data.NumInstances -- | Solves a system of the form 'A*X=D' for 'x' where 'A' is an -- 'n' by 'n' matrix with 'bs' as the main diagonal and @@ -38,18 +37,23 @@ cs' = c0 / b0 : f cs' as bs cs f _ [_] _ _ = [] f (c':cs') (a:as) (b:bs) (c:cs) = c / (b - c' * a) : f cs' as bs cs + f _ _ _ _ = error "solveTriDiagonal.f: impossible!" ds' = d0 / b0 : g ds' as bs cs' ds g _ [] _ _ _ = [] g (d':ds') (a:as) (b:bs) (c':cs') (d:ds) = (d - d' * a)/(b - c' * a) : g ds' as bs cs' ds + g _ _ _ _ _ = error "solveTriDiagonal.g: impossible!" h _ [d] = [d] h (c:cs) (d:ds) = let xs@(x:_) = h cs ds in d - c * x : xs + h _ _ = error "solveTriDiagonal.h: impossible!" +solveTriDiagonal _ _ _ _ = error "arguments 2,3,4 to solveTriDiagonal must be nonempty" + -- Helper that applies the passed function only to the last element of a list modifyLast :: (a -> a) -> [a] -> [a] -modifyLast f [] = [] -modifyLast f [a] = [f a] +modifyLast _ [] = [] +modifyLast f [a] = [f a] modifyLast f (a:as) = a : modifyLast f as -- Helper that builds a list of length n of the form: '[s,m,m,...,m,m,e]' @@ -62,8 +66,8 @@ h n = m : h (n - 1) -- | Solves a system similar to the tri-diagonal system using a special case --- of the Sherman--Morrison formula . --- This code is based on /Numerical Recpies in C/'s "cyclic" function in section 2.7. +-- of the Sherman-Morrison formula . +-- This code is based on /Numerical Recpies in C/'s @cyclic@ function in section 2.7. solveCyclicTriDiagonal :: Fractional a => [a] -> [a] -> [a] -> [a] -> a -> a -> [a] solveCyclicTriDiagonal as (b0:bs) cs ds alpha beta = zipWith ((+) . (fact *)) zs xs where @@ -78,6 +82,8 @@ fact = -(x + beta * last xs / gamma) / (1.0 + z + beta * last zs / gamma) +solveCyclicTriDiagonal _ _ _ _ _ _ = error "second argument to solveCyclicTriDiagonal must be nonempty" + -- | Use the tri-diagonal solver with the appropriate parameters for an open cubic spline. solveCubicSplineDerivatives :: Fractional a => [a] -> [a] solveCubicSplineDerivatives (x:xs) = solveTriDiagonal as bs as ds @@ -87,6 +93,8 @@ l = length ds ds = zipWith f (xs ++ [last xs]) (x:x:xs) f a b = 3*(a - b) + +solveCubicSplineDerivatives _ = error "argument to solveCubicSplineDerivatives must be nonempty" -- | Use the cyclic-tri-diagonal solver with the appropriate parameters for a closed cubic spline. solveCubicSplineDerivativesClosed :: Fractional a => [a] -> [a] diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -14,9 +14,11 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- Generic functionality for constructing and manipulating /trails/ --- (sequences of linear or cubic Bezier segments) and /paths/ --- (collections of concretely located trails). +-- This module defines /trails/ (translationally invariant sequences +-- of linear or cubic Bézier segments) and /paths/ (collections of +-- concretely located trails). Trails and paths can be used for +-- drawing shapes, laying out other diagrams, clipping, and other +-- things. -- ----------------------------------------------------------------------------- @@ -40,6 +42,7 @@ , trailSegments' , trailOffsets, trailOffset , trailVertices, reverseTrail + , addClosingSegment , fixTrail -- * Paths @@ -55,6 +58,8 @@ , pathVertices , pathOffsets + , pathCentroid + , expandPath , reversePath , fixPath @@ -67,15 +72,18 @@ ) where import Graphics.Rendering.Diagrams +import Graphics.Rendering.Diagrams.Points +import Diagrams.Align import Diagrams.Segment -import Diagrams.Util +import Diagrams.Points +import Diagrams.Transform import Data.VectorSpace import Data.AffineSpace -import Control.Newtype -import Data.Monoid +import Control.Newtype hiding (under) +import Data.Semigroup import qualified Data.Foldable as F import Data.List (mapAccumL) @@ -88,7 +96,7 @@ -- | Type class for path-like things, which must be monoids. -- Instances include 'Trail's, 'Path's, and two-dimensional 'Diagram's. -class (Monoid p, VectorSpace (V p)) => PathLike p where +class (Monoid' p, VectorSpace (V p)) => PathLike p where pathLike :: Point (V p) -- ^ The starting point of the -- path. Some path-like things @@ -96,6 +104,7 @@ -> Bool -- ^ Should the path be closed? -> [Segment (V p)] -- ^ Segments of the path. -> p + -- | A list of points is path-like; this instance simply computes the -- vertices of a path-like thing. instance VectorSpace v => PathLike [Point v] where @@ -141,7 +150,7 @@ close (Trail segs _) = Trail segs True open (Trail segs _) = Trail segs False -instance (VectorSpace v, Ord v) => Closeable (Path v) where +instance VectorSpace v => Closeable (Path v) where close = (over Path . map . second) close open = (over Path . map . second) open @@ -161,12 +170,15 @@ type instance V (Trail v) = v +instance Semigroup (Trail v) where + Trail t1 c1 <> Trail t2 c2 = Trail (t1 ++ t2) (c1 || c2) + -- | The empty trail has no segments. Trails are composed via -- concatenation. @t1 ``mappend`` t2@ is closed iff either @t1@ or -- @t2@ are. instance Monoid (Trail v) where mempty = Trail [] False - Trail t1 c1 `mappend` Trail t2 c2 = Trail (t1 ++ t2) (c1 || c2) + mappend = (<>) -- | Trails are 'PathLike' things. Note that since trails are -- translationally invariant, 'setStart' has no effect. @@ -177,14 +189,17 @@ instance HasLinearMap v => Transformable (Trail v) where transform t (Trail segs c) = Trail (transform t segs) c --- | The bounding function for a trail is based at the trail's start. -instance (InnerSpace v, OrderedField (Scalar v)) => Boundable (Trail v) where +-- | The envelope for a trail is based at the trail's start. +instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Trail v) where - getBounds (Trail segs _) = - foldr (\seg bds -> moveOriginTo (P . negateV . segOffset $ seg) bds <> getBounds seg) + getEnvelope (Trail segs _) = + foldr (\seg bds -> moveOriginTo (P . negateV . segOffset $ seg) bds <> getEnvelope seg) mempty segs +instance HasLinearMap v => Renderable (Trail v) NullBackend where + render _ _ = mempty + ------------------------------------------------------------ -- Computing with trails --------------------------------- ------------------------------------------------------------ @@ -214,7 +229,7 @@ reverseTrail t@(Trail {trailSegments = []}) = t reverseTrail t@(Trail {trailSegments = ss}) | isClosed t = t { trailSegments = straight (trailOffset t) : reverseSegs ss } - | otherwise = t { trailSegments = reverseSegs $ ss } + | otherwise = t { trailSegments = reverseSegs ss } where reverseSegs = fmap reverseSegment . reverse -- | Reverse a trail with a fixed starting point. @@ -228,12 +243,17 @@ pathLikeFromTrail :: PathLike p => Trail (V p) -> p pathLikeFromTrail t = pathLike origin (isClosed t) (trailSegments t) +-- | If the trail is closed, this adds in the closing segment. Otherwise, +-- the trail is returned unmodified. +addClosingSegment :: AdditiveGroup v => Trail v -> Trail v +addClosingSegment t | isClosed t = Trail (trailSegments t ++ [closeSeg]) False + | otherwise = 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] -fixTrail start tr = zipWith mkFixedSeg (trailVertices start tr) - (trailSegments tr ++ closeSeg) - where closeSeg | isClosed tr = [Linear . negateV . trailOffset $ tr] - | otherwise = [] +fixTrail start t = zipWith mkFixedSeg (trailVertices start t) + (trailSegments $ addClosingSegment t) ------------------------------------------------------------ -- Paths ------------------------------------------------- @@ -244,7 +264,7 @@ -- are /not/ translationally invariant, and form a monoid under -- superposition. newtype Path v = Path { pathTrails :: [(Point v, Trail v)] } - deriving (Show, Monoid, Eq, Ord) + deriving (Show, Semigroup, Monoid, Eq, Ord) type instance V (Path v) = v @@ -252,16 +272,16 @@ pack = Path unpack = pathTrails -instance (Ord v, VectorSpace v) => HasOrigin (Path v) where +instance VectorSpace v => HasOrigin (Path v) where moveOriginTo = over Path . map . first . moveOriginTo -- | Paths are (of course) path-like. 'fromSegments' creates a path -- with start point at the origin. -instance (Ord v, VectorSpace v) => PathLike (Path v) where +instance VectorSpace v => PathLike (Path v) where pathLike s cl segs = Path [(s, pathLike origin cl segs)] -- See Note [Transforming paths] -instance (HasLinearMap v, Ord v) => Transformable (Path v) where +instance HasLinearMap v => Transformable (Path v) where transform t = (over Path . map) (transform t *** transform t) {- ~~~~ Note [Transforming paths] @@ -274,12 +294,21 @@ of the v's are inside Points and hence ought to be translated. -} -instance (InnerSpace v, OrderedField (Scalar v)) => Boundable (Path v) where - getBounds = F.foldMap trailBounds . pathTrails +instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Path v) where + getEnvelope = F.foldMap trailEnvelope . pathTrails -- this type signature is necessary to work around an apparent bug in ghc 6.12.1 - where trailBounds :: (Point v, Trail v) -> Bounds v - trailBounds (p, t) = moveOriginTo ((-1) *. p) (getBounds t) + where trailEnvelope :: (Point v, Trail v) -> Envelope v + trailEnvelope (p, t) = moveOriginTo ((-1) *. p) (getEnvelope t) +instance (InnerSpace v, OrderedField (Scalar v)) => Juxtaposable (Path v) where + juxtapose = juxtaposeDefault + +instance (InnerSpace v, OrderedField (Scalar v)) => Alignable (Path v) where + alignBy = alignByDefault + +instance HasLinearMap v => Renderable (Path v) NullBackend where + render _ _ = mempty + ------------------------------------------------------------ -- Constructing paths from trails ------------------------ ------------------------------------------------------------ @@ -304,6 +333,17 @@ pathOffsets :: AdditiveGroup v => Path v -> [v] pathOffsets = map (trailOffset . snd) . pathTrails +-- | Compute the /centroid/ of a path (/i.e./ the average of its +-- vertices). +pathCentroid :: (VectorSpace v, Fractional (Scalar v)) => Path v -> Point v +pathCentroid = centroid . concat . pathVertices + +-- | 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 + -- | Reverse the direction of all the component trails of a path. reversePath :: AdditiveGroup v => Path v -> Path v reversePath = (over Path . map) reverseRootedTrail @@ -320,12 +360,12 @@ -- segment (including the implicit closing segment, if the trail is -- closed) into its own separate path. Useful for (say) applying a -- different style to each segment. -explodeTrail :: VectorSpace v => Point v -> Trail v -> [Path v] +explodeTrail :: (VectorSpace (V p), PathLike p) => Point (V p) -> Trail (V p) -> [p] explodeTrail start = snd . mapAccumL mkPath start . trailSegments' - where mkPath p seg = (p .+^ segOffset seg, pathFromTrailAt (fromSegments [seg]) p) + where mkPath p seg = (p .+^ segOffset seg, pathLike p False [seg]) -- | \"Explode\" a path by exploding every component trail (see 'explodeTrail'). -explodePath :: VectorSpace v => Path v -> [[Path v]] +explodePath :: (VectorSpace (V p), PathLike p) => Path (V p) -> [[p]] explodePath = map (uncurry explodeTrail) . pathTrails -- | Create a single-segment path between two given points. diff --git a/src/Diagrams/Points.hs b/src/Diagrams/Points.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Points.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE FlexibleContexts + #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Points +-- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Some miscellaneous utilities for working with points. +-- +----------------------------------------------------------------------------- + +module Diagrams.Points + ( centroid + + ) where + +import Graphics.Rendering.Diagrams + +import Control.Newtype + +import Control.Arrow ((&&&)) + +import Data.VectorSpace + +-- | The centroid of a set of /n/ points is their sum divided by /n/. +centroid :: (VectorSpace v, Fractional (Scalar v)) => [Point v] -> Point v +centroid = pack . uncurry (^/) . (sumV &&& (fromIntegral . length)) . map unpack diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -22,7 +22,7 @@ -- | Attributes (color, line style, etc.) and styles. , module Diagrams.Attributes - -- | General alignment of diagrams. + -- | Alignment of diagrams relative to their envelopes. , module Diagrams.Align -- | Combining multiple diagrams into one. @@ -41,7 +41,8 @@ -- conjugation of transformations. , module Diagrams.Transform - -- | Convenient definitions and + -- | Convenient definitions and utilities for working with + -- good old-fashioned, axis-aligned bounding boxes. , module Diagrams.BoundingBox -- | A wide range of things (shapes, transformations, @@ -49,20 +50,27 @@ -- diagrams. , module Diagrams.TwoD + -- | Tools for making animations. + , module Diagrams.Animation + -- | Various utility definitions. , module Diagrams.Util -- * Convenience re-exports -- | A large list of color names. , module Data.Colour.Names - -- | Monoids show up all over the place, so things from - -- Data.Monoid often come in handy. - , module Data.Monoid + -- | Semigroups and monoids show up all over the place, so things from + -- Data.Semigroup and Data.Monoid often come in handy. + , module Data.Semigroup -- | For computing with vectors. , module Data.VectorSpace -- | For computing with points and vectors. , module Data.AffineSpace + -- | For working with 'Active' (i.e. animated) things. + , module Data.Active + + , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 ) where import Graphics.Rendering.Diagrams @@ -76,10 +84,13 @@ import Diagrams.Transform import Diagrams.BoundingBox import Diagrams.TwoD +import Diagrams.Animation import Diagrams.Util -import Data.Monoid +import Data.Colour.Names +import Data.Semigroup import Data.VectorSpace hiding (Sum(..)) import Data.AffineSpace +import Data.Active +import Control.Applicative -import Data.Colour.Names diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies , FlexibleContexts , FlexibleInstances + , MultiParamTypeClasses , DeriveFunctor , UndecidableInstances #-} @@ -11,9 +12,18 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- Generic functionality for constructing and manipulating linear or --- cubic Bezier segments. +-- A /segment/ is a translation-invariant, atomic path. There are two +-- types: linear (/i.e./ just a straight line to the endpoint) and +-- cubic Bézier curves (/i.e./ a curve to an endpoint with two control +-- points). This module contains tools for creating and manipulating +-- segments, as well as a definition of segments with a fixed location +-- (useful for backend implementors). -- +-- Generally speaking, casual users of diagrams should not need this +-- module; the higher-level functionality provided by "Diagrams.Path" +-- should usually suffice instead. However, directly manipulating +-- segments can occasionally be useful. +-- ----------------------------------------------------------------------------- module Diagrams.Segment @@ -36,7 +46,6 @@ , adjustSegmentToParams -- * Fixed (absolutely located) segments - , FixedSegment(..) , mkFixedSeg , fAtParam @@ -53,19 +62,20 @@ import Data.VectorSpace import Control.Applicative (liftA2) +import Data.Semigroup ------------------------------------------------------------ -- Constructing segments --------------------------------- ------------------------------------------------------------ -- | The atomic constituents of paths are /segments/, which are single --- straight lines or cubic Bezier curves. Segments are +-- straight lines or cubic Bézier curves. Segments are -- /translationally invariant/, that is, they have no particular -- \"location\" and are unaffected by translations. They are, -- however, affected by other transformations such as rotations and -- scales. data Segment v = Linear v -- ^ A linear segment with given offset. - | Cubic v v v -- ^ A cubic bezier segment specified by + | Cubic v v v -- ^ A cubic Bézier segment specified by -- three offsets from the starting -- point to the first control point, -- second control point, and ending @@ -77,6 +87,9 @@ instance HasLinearMap v => Transformable (Segment v) where transform = fmap . apply +instance HasLinearMap v => Renderable (Segment v) NullBackend where + render _ _ = mempty + -- | @'straight' v@ constructs a translationally invariant linear -- segment with direction and length given by the vector @v@. straight :: v -> Segment v @@ -88,7 +101,7 @@ -- observe how segments are parametrized. -- | @bezier3 v1 v2 v3@ constructs a translationally invariant cubic --- Bezier curve where the offsets from the first endpoint to the +-- Bézier curve where the offsets from the first endpoint to the -- first and second control point and endpoint are respectively -- given by @v1@, @v2@, and @v3@. bezier3 :: v -> v -> v -> Segment v @@ -106,7 +119,7 @@ where t' = 1-t -- | Compute the offset from the start of a segment to the --- end. Note that in the case of a Bezier segment this is /not/ the +-- end. Note that in the case of a Bézier segment this is /not/ the -- same as the length of the curve itself; for that, see 'arcLength'. segOffset :: Segment v -> v segOffset (Linear v) = v @@ -118,7 +131,7 @@ reverseSegment (Cubic c1 c2 x2) = Cubic (c2 ^-^ x2) (c1 ^-^ x2) (negateV x2) ------------------------------------------------------------ --- Computing segment bounds ------------------------------ +-- Computing segment envelope ------------------------------ ------------------------------------------------------------ {- 3 (1-t)^2 t c1 + 3 (1-t) t^2 c2 + t^3 x2 @@ -143,14 +156,13 @@ Set equal to zero, use quadratic formula. -} --- | The bounding function for a segment is based at the segment's --- start. -instance (InnerSpace v, OrderedField (Scalar v)) => Boundable (Segment v) where +-- | The envelope for a segment is based at the segment's start. +instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Segment v) where - getBounds (s@(Linear {})) = Bounds $ \v -> + getEnvelope (s@(Linear {})) = mkEnvelope $ \v -> maximum . map (\t -> ((s `atParam` t) <.> v) / magnitudeSq v) $ [0,1] - getBounds (s@(Cubic c1 c2 x2)) = Bounds $ \v -> + getEnvelope (s@(Cubic c1 c2 x2)) = mkEnvelope $ \v -> maximum . map (\t -> ((s `atParam` t) <.> v) / magnitudeSq v) $ [0,1] ++ @@ -255,6 +267,7 @@ -- | How should a segment, trail, or path be adjusted? data AdjustOpts v = ALO { adjMethod :: AdjustMethod v , adjSide :: AdjustSide + , adjEps :: Scalar v , adjOptsvProxy__ :: Proxy v } @@ -265,31 +278,26 @@ def = Both instance Fractional (Scalar v) => Default (AdjustOpts v) where - def = ALO def def Proxy + def = ALO def def (1/10^(10 :: Integer)) Proxy -- | Adjust the length of a segment. The second parameter is an -- option record which controls how the adjustment should be -- performed; see 'AdjustOpts'. adjustSegment :: (InnerSpace v, OrderedField (Scalar v)) => Segment v -> AdjustOpts v -> Segment v -adjustSegment s opts = adjustSegmentToParams s t1 t2 - where t1 = case opts of - (ALO _ End _) -> 0 - (ALO (ByParam p) Start _) -> -p - (ALO (ByParam p) Both _) -> -p/2 - (ALO (ByAbsolute len) Start _) -> arcLengthToParam s (-len) eps - (ALO (ByAbsolute len) Both _) -> arcLengthToParam s (-len/2) eps - (ALO (ToAbsolute len) Start _) -> arcLengthToParam s (arcLength s eps - len) eps - (ALO (ToAbsolute len) Both _) -> arcLengthToParam s ((arcLength s eps - len)/2) eps - t2 = case opts of - (ALO _ Start _) -> 1 - (ALO (ByParam p) End _) -> 1 + p - (ALO (ByParam p) Both _) -> 1 + p/2 - (ALO (ByAbsolute len) End _) -> 1 - arcLengthToParam (reverseSegment s) (-len) eps - (ALO (ByAbsolute len) Both _) -> 1 - (arcLengthToParam (reverseSegment s) (-len) eps)/2 - (ALO (ToAbsolute len) End _) -> 1 - arcLengthToParam (reverseSegment s) (arcLength s eps - len) eps - (ALO (ToAbsolute len) Both _) -> 1 - arcLengthToParam (reverseSegment s) ((arcLength s eps - len)/2) eps - eps = 1/10^(10 :: Integer) +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 + ByParam p -> -p * bothCoef + ByAbsolute len -> param (-len * bothCoef) + ToAbsolute len -> param (absDelta len * bothCoef) + where + param l = arcLengthToParam seg l eps + absDelta len = arcLength s eps - len + bothCoef = if adjSide opts == Both then 0.5 else 1 + eps = adjEps opts -- | Given a segment and parameters @t1@, @t2@, produce the segment -- which lies on the (infinitely extended) original segment @@ -325,7 +333,7 @@ (moveOriginTo o c2) (moveOriginTo o p2) --- instance Boundable (FixedSegment v) where +-- instance Enveloped (FixedSegment v) where -- XXX write me -- | Create a 'FixedSegment' from a starting point and a 'Segment'. diff --git a/src/Diagrams/Solve.hs b/src/Diagrams/Solve.hs --- a/src/Diagrams/Solve.hs +++ b/src/Diagrams/Solve.hs @@ -17,7 +17,7 @@ import Data.List (maximumBy) import Data.Ord (comparing) -import Math.Tau +import Diagrams.Util (tau) ------------------------------------------------------------ -- Quadratic formula 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 + , ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -21,9 +22,8 @@ import Graphics.Rendering.Diagrams import Diagrams.ThreeD.Types -import Diagrams.Util -import Data.Monoid +import Data.Semigroup data Ellipsoid = Ellipsoid T3 @@ -33,9 +33,9 @@ transform t1 (Ellipsoid t2) = Ellipsoid (t1 <> t2) sphere :: (Backend b R3, Renderable Ellipsoid b) => Diagram b R3 -sphere = mkAD (Prim $ Ellipsoid mempty) - (Bounds sphereBounds) +sphere = mkQD (Prim $ Ellipsoid mempty) + (mkEnvelope sphereEnv) mempty (Query sphereQuery) - where sphereBounds (x,y,z) = 1 / sqrt(x*x + y*y + z*z) - sphereQuery (P (x,y,z)) = Any $ x*x + y*y + z*z <= 1 + 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 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,6 +1,9 @@ {-# LANGUAGE TypeSynonymInstances , FlexibleInstances , TypeFamilies + , ViewPatterns + , MultiParamTypeClasses + , GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -17,24 +20,63 @@ module Diagrams.ThreeD.Types ( -- * 3D Euclidean space - R3 - , P3 + R3, r3, unr3 + , P3, p3, unp3 , T3 ) where import Graphics.Rendering.Diagrams +import Control.Newtype + +import Data.Basis +import Data.VectorSpace + ------------------------------------------------------------ -- 3D Euclidean space -- | The three-dimensional Euclidean vector space R^3. -type R3 = (Double, Double, Double) +newtype R3 = R3 { unR3 :: (Double, Double, Double) } + deriving (AdditiveGroup, Eq, Ord, Show, Read) +instance Newtype R3 (Double, Double, Double) where + pack = R3 + unpack = unR3 + +-- | Construct a 3D vector from a triple of components. +r3 :: (Double, Double, Double) -> R3 +r3 = pack + +-- | Convert a 3D vector back into a triple of components. +unr3 :: R3 -> (Double, Double, Double) +unr3 = unpack + type instance V R3 = R3 +instance VectorSpace R3 where + type Scalar R3 = Double + (*^) = over R3 . (*^) + +instance HasBasis R3 where + type Basis R3 = Either () (Either () ()) -- = Basis (Double, Double, Double) + basisValue = R3 . basisValue + decompose = decompose . unR3 + decompose' = decompose' . unR3 + +instance InnerSpace R3 where + (unR3 -> vec1) <.> (unR3 -> vec2) = vec1 <.> vec2 + -- | Points in R^3. type P3 = Point R3 + +-- | Construct a 3D point from a triple of coordinates. +p3 :: (Double, Double, Double) -> P3 +p3 = pack . pack + +-- | Convert a 2D point back into a triple of coordinates. +unp3 :: P3 -> (Double, Double, Double) +unp3 = unpack . unpack -- | Transformations in R^3. type T3 = Transformation R3 diff --git a/src/Diagrams/Transform.hs b/src/Diagrams/Transform.hs --- a/src/Diagrams/Transform.hs +++ b/src/Diagrams/Transform.hs @@ -15,7 +15,7 @@ ) where import Graphics.Rendering.Diagrams -import Diagrams.Util +import Data.Semigroup -- | Conjugate one transformation by another. @conjugate t1 t2@ is the -- transformation which performs first @t1@, then @t2@, then the diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -51,13 +51,14 @@ -- size of 2D objects. -- -- * "Diagrams.TwoD.Model" defines some aids for visualizing --- diagrams' internal model (local origins, bounding regions, --- etc.) +-- diagrams' internal model (local origins, envelopes, etc.) -- ----------------------------------------------------------------------------- module Diagrams.TwoD ( -- * R^2 - R2, P2, T2 + R2, r2, unr2 + , P2, p2, unp2 + , T2 , unitX, unitY, unit_X, unit_Y , direction, fromDirection, e @@ -83,7 +84,6 @@ -- ** Circle-ish things , unitCircle , circle - , circlePath , ellipse , ellipseXY , arc @@ -114,10 +114,12 @@ , rect -- ** Other shapes - , roundedRect + , roundedRect, roundedRect' + , RoundedRectOpts(..) -- * Text - , text, font, fontSize, italic, oblique, bold + , text, topLeftText, alignedText, baselineText + , font, fontSize, italic, oblique, bold -- * Images , image @@ -140,14 +142,19 @@ , reflectionX, reflectX , reflectionY, reflectY , reflectionAbout, reflectAbout + -- ** Shears + , shearingX, shearX + , shearingY, shearY -- * Combinators - , strutX, strutY - - , (===), (|||) + , (===), (|||), atAngle , hcat, hcat' , vcat, vcat' + , strutX, strutY + , padX, padY + , view + -- * Alignment , alignL, alignR, alignT, alignB, alignTL, alignTR, alignBL, alignBR , alignX, alignY @@ -160,15 +167,16 @@ -- ** Specifying size , SizeSpec2D(..) + , mkSizeSpec -- * Visual aids for understanding the internal model , showOrigin + , showOrigin' + , OriginOpts(..) , showLabels ) where -import Math.Tau - import Diagrams.TwoD.Types import Diagrams.TwoD.Path import Diagrams.TwoD.Ellipse @@ -183,3 +191,5 @@ import Diagrams.TwoD.Model import Diagrams.TwoD.Text import Diagrams.TwoD.Image + +import Diagrams.Util (tau) diff --git a/src/Diagrams/TwoD/Adjust.hs b/src/Diagrams/TwoD/Adjust.hs --- a/src/Diagrams/TwoD/Adjust.hs +++ b/src/Diagrams/TwoD/Adjust.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE ViewPatterns + #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Adjust @@ -13,6 +16,7 @@ module Diagrams.TwoD.Adjust ( adjustDia2D , adjustSize + , requiredScale ) where import Graphics.Rendering.Diagrams @@ -20,20 +24,20 @@ import Diagrams.Attributes (lw, lc) import Diagrams.Util ((#)) -import Diagrams.TwoD.Types (R2) +import Diagrams.TwoD.Types (R2, p2) import Diagrams.TwoD.Size (size2D, center2D, SizeSpec2D(..)) import Diagrams.TwoD.Text (fontSize) import Data.AffineSpace ((.-.)) import Data.Colour.Names (black) -import Data.Monoid (Monoid, mempty) -- | @adjustDia2D@ provides a useful default implementation of -- the 'adjustDia' method from the 'Backend' type class. -- --- As its first argument it requires a method for extracting the --- requested output size from the rendering options. +-- 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: -- @@ -48,32 +52,53 @@ -- * 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. -adjustDia2D :: Monoid m => (Options b R2 -> R2) -> b -> Options b R2 -> AnnDiagram b R2 m -> AnnDiagram b R2 m -adjustDia2D getSize _ opts d = d # lw 0.01 # lc black # fontSize 1 # freeze - # scale s - # translate tr - where (w,h) = getSize opts - (wd,hd) = size2D d - xscale = w / wd - yscale = h / hd - s' = min xscale yscale - s | isInfinite s' = 1 - | otherwise = s' - tr = (0.5 *. P (w,h)) .-. (s *. center2D d) +-- 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 = + ( case spec of + Dims _ _ -> opts + _ -> setSize (uncurry Dims . scale s $ size) opts --- | @adjustSize spec sz@ returns a transformation which can be --- applied to something of size @sz@ to make it the requested size --- @spec@. -adjustSize :: SizeSpec2D -> R2 -> Transformation R2 -adjustSize Absolute _ = mempty -adjustSize (Width wSpec) (w,_) - | wSpec == 0 || w == 0 = mempty - | otherwise = scaling (wSpec / w) -adjustSize (Height hSpec) (_,h) - | hSpec == 0 || h == 0 = mempty - | otherwise = scaling (hSpec / h) -adjustSize (Dims wSpec hSpec) (w,h) = scaling s + , d # lw 0.01 # lc black # fontSize 1 # freeze + # scale s + # translate tr + ) + where spec = getSize opts + size = size2D d + s = requiredScale spec size + finalSz = case spec of + Dims w h -> (w,h) + _ -> scale s size + tr = (0.5 *. p2 finalSz) .-. (s *. center2D d) + +-- | @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) + +-- | @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 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 @@ -12,11 +12,11 @@ -- "Diagrams.Align" for more general alignment combinators. -- -- The basic idea is that alignment is achieved by moving diagrams' --- local origins relative to their bounding regions. For example, to --- align several diagrams along their tops, we first move their local --- origins to the upper edge of their bounding regions (using --- e.g. @map 'alignTop'@), and then put them together with their local --- origins along a horizontal line (using e.g. 'hcat' from +-- local origins relative to their envelopes. For example, to align +-- several diagrams along their tops, we first move their local +-- origins to the upper edge of their envelopes (using e.g. @map +-- 'alignTop'@), and then put them together with their local origins +-- along a horizontal line (using e.g. 'hcat' from -- "Diagrams.TwoD.Combinators"). -- ----------------------------------------------------------------------------- @@ -44,23 +44,23 @@ -- | Align along the left edge, i.e. translate the diagram in a -- horizontal direction so that the local origin is on the left edge --- of the bounding region. -alignL :: (HasOrigin a, Boundable a, V a ~ R2) => a -> a +-- of the envelope. +alignL :: (Alignable a, V a ~ R2) => a -> a alignL = align (negateV unitX) -- | Align along the right edge. -alignR :: (HasOrigin a, Boundable a, V a ~ R2) => a -> a +alignR :: (Alignable a, V a ~ R2) => a -> a alignR = align unitX -- | Align along the top edge. -alignT :: (HasOrigin a, Boundable a, V a ~ R2) => a -> a +alignT :: (Alignable a, V a ~ R2) => a -> a alignT = align unitY -- | Align along the bottom edge. -alignB :: (HasOrigin a, Boundable a, V a ~ R2) => a -> a +alignB :: (Alignable a, V a ~ R2) => a -> a alignB = align (negateV unitY) -alignTL, alignTR, alignBL, alignBR :: (HasOrigin a, Boundable a, V a ~ R2) => a -> a +alignTL, alignTR, alignBL, alignBR :: (Alignable a, V a ~ R2) => a -> a alignTL = alignT . alignL alignTR = alignT . alignR alignBL = alignB . alignL @@ -68,30 +68,30 @@ -- | @alignX@ moves the local origin horizontally as follows: -- --- * @alignX (-1)@ moves the local origin to the left edge of the bounding region; +-- * @alignX (-1)@ moves the local origin to the left edge of the envelope; -- -- * @align 1@ moves the local origin to the right edge; -- -- * any other argument interpolates linearly between these. For -- example, @alignX 0@ centers, @alignX 2@ moves the origin one -- \"radius\" to the right of the right edge, and so on. -alignX :: (HasOrigin a, Boundable a, V a ~ R2) => Double -> a -> a +alignX :: (Alignable a, V a ~ R2) => Double -> a -> a alignX = alignBy unitX -- | Like 'alignX', but moving the local origin vertically, with an -- argument of @1@ corresponding to the top edge and @(-1)@ corresponding -- to the bottom edge. -alignY :: (HasOrigin a, Boundable a, V a ~ R2) => Double -> a -> a +alignY :: (Alignable a, V a ~ R2) => Double -> a -> a alignY = alignBy unitY -- | Center the local origin along the X-axis. -centerX :: (HasOrigin a, Boundable a, V a ~ R2) => a -> a +centerX :: (Alignable a, V a ~ R2) => a -> a centerX = alignBy unitX 0 -- | Center the local origin along the Y-axis. -centerY :: (HasOrigin a, Boundable a, V a ~ R2) => a -> a +centerY :: (Alignable a, V a ~ R2) => a -> a centerY = alignBy unitY 0 -- | Center along both the X- and Y-axes. -centerXY :: (HasOrigin a, Boundable a, V a ~ R2) => a -> a +centerXY :: (Alignable a, V a ~ R2) => a -> a centerXY = centerX . centerY 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 @@ -1,4 +1,6 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies + , ViewPatterns + #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Arc @@ -12,25 +14,23 @@ module Diagrams.TwoD.Arc ( arc + , arcT , bezierFromSweep - , circlePath - , wedge ) where import Graphics.Rendering.Diagrams -import Math.Tau - import Diagrams.TwoD.Types import Diagrams.TwoD.Transform import Diagrams.TwoD.Vector (unitX, e) import Diagrams.Path import Diagrams.Segment -import Diagrams.Util ((#), (<>)) +import Diagrams.Util ((#), tau) +import Data.Semigroup ((<>)) import Data.VectorSpace((^-^), (*^), negateV) -- For details of this approximation see: @@ -41,11 +41,11 @@ -- radians. The approximation is only valid for angles in the first -- quadrant. bezierFromSweepQ1 :: Rad -> Segment R2 -bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s/2) $ Cubic p2 p1 p0 - where p0@(x,y) = rotate (s/2) v - p1 = ((4-x)/3, (1-x)*(3-x)/(3*y)) - p2 = reflectY p1 - v = (1,0) +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 -- | @bezierFromSweep s@ constructs a series of 'Cubic' segments that -- start in the positive y direction and sweep counter clockwise @@ -90,14 +90,9 @@ -- | 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. arc :: (Angle a, PathLike p, V p ~ R2) => a -> a -> p -arc start end = pathLike (rotate start $ P unitX) +arc start end = pathLike (rotate start $ p2 (1,0)) False (trailSegments $ arcT start end) - --- | Create a closed circular path of the given radius, centered at --- the origin, beginning at (r,0). -circlePath :: (PathLike p, Closeable p, V p ~ R2, Transformable p) => Double -> p -circlePath r = arc 0 (tau::Rad) # close # scale r -- | 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 @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts , TypeFamilies + , ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -17,32 +18,41 @@ ( -- * Binary combinators - (===), (|||) + (===), (|||), atAngle -- * n-ary combinators , hcat, hcat' , vcat, vcat' - -- * Struts + -- * Spacing/envelopes , strutX, strutY + , padX, padY + + , view + ) where import Graphics.Rendering.Diagrams +import Diagrams.TwoD.Transform (scaleX, scaleY) import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (unitX, unitY) +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.Monoid +import Data.Semigroup import Data.Default infixl 6 === infixl 6 ||| --- | Place two diagrams (or other boundable objects) vertically +-- | Place two diagrams (or other objects) vertically -- adjacent to one another, with the first diagram above the second. -- Since Haskell ignores whitespace in expressions, one can thus write -- @@ -50,19 +60,33 @@ -- > === -- > d -- --- to place @c@ above @d@. -(===) :: (HasOrigin a, Boundable a, V a ~ R2, Monoid a) => a -> a -> a +-- to place @c@ above @d@. The local origin of the resulting +-- combined diagram is the same as the local origin of the first. +-- @(===)@ is associative and has 'mempty' as a right (but not left) +-- identity. See the documentation of 'beside' for more information. +(===) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a (===) = beside (negateV unitY) --- | Place two diagrams (or other boundable objects) horizontally +-- | Place two diagrams (or other juxtaposable objects) horizontally -- adjacent to one another, with the first diagram to the left of --- the second. -(|||) :: (HasOrigin a, Boundable a, V a ~ R2, Monoid a) => a -> a -> a +-- the second. The local origin of the resulting +-- combined diagram is the same as the local origin of the first. +-- @(===)@ is associative and has 'mempty' as a right (but not left) +-- identity. See the documentation of 'beside' for more information. +(|||) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a (|||) = beside unitX --- | Lay out a list of boundable objects in a row from left to right, +-- | Place two diagrams (or other juxtaposable objects) adjacent to one +-- another, with the second diagram placed along a line at angle +-- 'th' from the first. The local origin of the resulting combined +-- diagram is the same as the local origin of the first. +-- See the documentation of 'beside' for more information. +atAngle :: (Juxtaposable a, V a ~ R2, Semigroup a, Angle b) => b -> a -> a -> a +atAngle th = beside (fromDirection th) + +-- | Lay out a list of juxtaposable objects in a row from left to right, -- so that their local origins lie along a single horizontal line, --- with successive bounding regions tangent to one another. +-- with successive envelopes tangent to one another. -- -- * For more control over the spacing, see 'hcat''. -- @@ -71,18 +95,20 @@ -- "Diagrams.TwoD.Align" before applying 'hcat'. -- -- * For non-axis-aligned layout, see 'cat'. -hcat :: (HasOrigin a, Boundable a, V a ~ R2, Monoid a) => [a] -> a +hcat :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) + => [a] -> a hcat = hcat' def -- | A variant of 'hcat' taking an extra 'CatOpts' record to control -- the spacing. See the 'cat'' documentation for a description of -- the possibilities. -hcat' :: (HasOrigin a, Boundable a, V a ~ R2, Monoid a) => CatOpts R2 -> [a] -> a +hcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) + => CatOpts R2 -> [a] -> a hcat' = cat' unitX --- | Lay out a list of boundable objects in a column from top to bottom, --- so that their local origins lie along a single vertical line, --- with successive bounding regions tangent to one another. +-- | Lay out a list of juxtaposable objects in a column from top to +-- bottom, so that their local origins lie along a single vertical +-- line, with successive envelopes tangent to one another. -- -- * For more control over the spacing, see 'vcat''. -- @@ -91,23 +117,56 @@ -- "Diagrams.TwoD.Align" before applying 'vcat'. -- -- * For non-axis-aligned layout, see 'cat'. -vcat :: (HasOrigin a, Boundable a, V a ~ R2, Monoid a) => [a] -> a +vcat :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) + => [a] -> a vcat = vcat' def -- | A variant of 'vcat' taking an extra 'CatOpts' record to control -- the spacing. See the 'cat'' documentation for a description of the -- possibilities. -vcat' :: (HasOrigin a, Boundable a, V a ~ R2, Monoid a) => CatOpts R2 -> [a] -> a +vcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) + => CatOpts R2 -> [a] -> a vcat' = cat' (negateV unitY) -- | @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 -> AnnDiagram b R2 m -strutX d = strut (d,0) +strutX :: (Backend b R2, Monoid' m) => Double -> QDiagram b R2 m +strutX d = strut (r2 (d,0)) -- | @strutY d@ is an empty diagram with height @d@, width 0, and a --- centered local origin. Note that @strutX (-w)@ behaves the same as --- @strutX w@. -strutY :: (Backend b R2, Monoid m) => Double -> AnnDiagram b R2 m -strutY d = strut (0,d) +-- centered local origin. Note that @strutY (-w)@ behaves the same as +-- @strutY w@. +strutY :: (Backend b R2, Monoid' m) => Double -> QDiagram b R2 m +strutY d = strut (r2 (0,d)) + +-- | @padX s@ \"pads\" a diagram in the x-direction, expanding its +-- envelope horizontally by a factor of @s@ (factors between 0 and 1 +-- can be used to shrink the envelope). Note that the envelope will +-- expand with respect to the local origin, so if the origin is not +-- centered horizontally the padding may appear \"uneven\". If this +-- is not desired, the origin can be centered (using 'centerX') +-- before applying @padX@. +padX :: ( Backend b R2, Monoid' m ) + => Double -> QDiagram b R2 m -> QDiagram b R2 m +padX s d = withEnvelope (d # scaleX s) d + +-- | @padY s@ \"pads\" a diagram in the y-direction, expanding its +-- envelope vertically by a factor of @s@ (factors between +-- 0 and 1 can be used to shrink the envelope). Note that +-- the envelope will expand with respect to the local origin, +-- so if the origin is not centered vertically the padding may appear +-- \"uneven\". If this is not desired, the origin can be centered +-- (using 'centerY') before applying @padY@. +padY :: ( Backend b R2, Monoid' m ) + => Double -> QDiagram b R2 m -> QDiagram b R2 m +padY s d = withEnvelope (d # scaleY s) d + +-- | @view p v@ sets the envelope of a diagram to a rectangle whose +-- lower-left corner is at @p@ and whose upper-right corner is at @p +-- .+^ v@. Useful for selecting the rectangular portion of a +-- diagram which should actually be \"viewed\" in the final render, +-- if you don't want to see the entire diagram. +view :: ( Backend b R2, Monoid' m ) + => P2 -> R2 -> QDiagram b R2 m -> QDiagram b R2 m +view p (unr2 -> (w,h)) = withEnvelope (rect w h # alignBL # moveTo p :: D R2) 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 @@ -21,59 +21,30 @@ , circle , ellipse , ellipseXY - - -- * Mathematical ellipses - -- ** Representation - , Ellipse(..) - - -- ** Extracting attributes - , ellipseCenter - , ellipseAngle - , ellipseAxes - , ellipseScale - - , ellipseCoeffs - ) where import Graphics.Rendering.Diagrams import Diagrams.TwoD.Types import Diagrams.TwoD.Transform -import Diagrams.Util - -import Data.Monoid (Any(..), mempty) - -import Data.VectorSpace (magnitudeSq, magnitude, (^-^)) - -import Math.Tau - --- | An ellipse is represented by an affine transformation acting on --- the unit circle. -data Ellipse = Ellipse T2 - -type instance V Ellipse = R2 +import Diagrams.TwoD.Arc -instance Transformable Ellipse where - transform t (Ellipse e) = Ellipse (t <> e) +import Diagrams.Path +import Diagrams.Util -- | A circle of radius 1, with center at the origin. -unitCircle :: (Backend b R2, Renderable Ellipse b) => Diagram b R2 -unitCircle = mkAD (Prim $ Ellipse mempty) - (Bounds circleBounds) - mempty - (Query circleQuery) - where circleBounds (x,y) = 1 / sqrt(x*x + y*y) - circleQuery (P (x,y)) = Any $ x*x + y*y <= 1 +unitCircle :: (PathLike p, V p ~ R2) => p +unitCircle = pathLike (p2 (1,0)) True $ trailSegments (arcT 0 (tau::Rad)) --- | A circle of the given radius, centered at the origin. -circle :: (Backend b R2, Renderable Ellipse b) => Double -> Diagram b R2 +-- | A circle of the given radius, centered at the origin. As a path, +-- it begins at (r,0). +circle :: (PathLike p, V p ~ R2, Transformable p) => Double -> p circle d = unitCircle # scale d -- | @ellipse e@ constructs an ellipse with eccentricity @e@ by -- scaling the unit circle in the X direction. The eccentricity must -- be within the interval [0,1). -ellipse :: (Backend b R2, Renderable Ellipse b) => Double -> Diagram b R2 +ellipse :: (PathLike p, V p ~ R2, Transformable p) => Double -> p ellipse e | e >= 0 && e < 1 = scaleX (sqrt (1 - e*e)) unitCircle | otherwise = error "Eccentricity of ellipse must be >= 0 and < 1." @@ -81,53 +52,5 @@ -- | @ellipseXY x y@ creates an axis-aligned ellipse, centered at the -- origin, with radius @x@ along the x-axis and radius @y@ along the -- y-axis. -ellipseXY :: (Backend b R2, Renderable Ellipse b) => Double -> Double -> Diagram b R2 +ellipseXY :: (PathLike p, V p ~ R2, Transformable p) => Double -> Double -> p ellipseXY x y = unitCircle # scaleX x # scaleY y - --- | Compute the coefficients of the quadratic form --- --- A x^2 + B x y + C y^2 + D x + E y + F = 0 --- --- for an ellipse. Returns A through F (in that order) as a tuple. -ellipseCoeffs :: Ellipse -> (Double, Double, Double, Double, Double, Double) -ellipseCoeffs (Ellipse eT) = ( a*a + d*d -- x^2 - , 2 * (a*b + d*e) -- xy - , b*b + e*e -- y^2 - , 2 * (a*c + d*f) -- x - , 2 * (b*c + e*f) -- y - , c*c + f*f - 1 - ) - where eT' = inv eT - (a,d) = apply eT' (1,0) - (b,e) = apply eT' (0,1) - (c,f) = transl eT' - --- | Compute the center of an ellipse. -ellipseCenter :: Ellipse -> P2 -ellipseCenter (Ellipse e) = papply e origin - --- | Compute the angle to the major axis of an ellipse, measured --- counterclockwise from the positive x axis in radians. The result --- will be in the range [0, tau/2). -ellipseAngle :: Ellipse -> Rad -ellipseAngle ell - | y < 0 = Rad $ tau/2 + atan2 y x - | otherwise = Rad $ atan2 y x - where ((x,y),_) = ellipseAxes ell - --- | Compute the vectors (va, vb) from the center of the ellipse to the edge of the --- ellipse along the major and minor axes. These vectors can lie in any quadrant, --- depending on how the ellipse has been transformed. -ellipseAxes :: Ellipse -> (R2, R2) -ellipseAxes (Ellipse eT) = if magnitudeSq va >= magnitudeSq vb then (va,vb) else (vb,va) - where a = apply eT (1,0) - b = apply eT (0,1) - v = apply eT (0,0) - va = a ^-^ v - vb = b ^-^ v - --- | Compute the scaling factors of an ellipse, i.e. (a,b) where a and --- b are half the lengths of the major and minor axes respectively. -ellipseScale :: Ellipse -> (Double, Double) -ellipseScale ell = (magnitude a, magnitude b) - where (a,b) = ellipseAxes ell diff --git a/src/Diagrams/TwoD/Image.hs b/src/Diagrams/TwoD/Image.hs --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies , FlexibleContexts + , MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | @@ -25,11 +26,10 @@ import Diagrams.TwoD.Path import Diagrams.TwoD.Shapes import Diagrams.TwoD.Size (SizeSpec2D(..)) -import Diagrams.Util import Data.AffineSpace ((.-.)) -import Data.Monoid +import Data.Semigroup -- | An external image primitive, representing an image the backend -- should import from another file when rendering. @@ -46,6 +46,9 @@ instance HasOrigin Image where moveOriginTo p = translate (origin .-. p) +instance Renderable Image NullBackend where + render _ _ = mempty + -- See Note [Image size specification] -- | Take an external image from the specified file and turn it into a @@ -54,8 +57,8 @@ -- the specified width and height have a different ratio than the -- image's aspect ratio, there will be extra space in one dimension. image :: (Renderable Image b) => FilePath -> Double -> Double -> Diagram b R2 -image file w h = mkAD (Prim (Image file (Dims w h) mempty)) - (getBounds r) +image file w h = mkQD (Prim (Image file (Dims w h) mempty)) + (getEnvelope 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 @@ -8,54 +8,69 @@ -- Maintainer : diagrams-discuss@googlegroups.com -- -- Tools for visualizing diagrams' internal model: local origins, --- bounding regions, etc. +-- envelopes, /etc./ -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Model ( -- * Showing the local origin showOrigin + , showOrigin' + , OriginOpts(..) , showLabels ) where import Graphics.Rendering.Diagrams import Graphics.Rendering.Diagrams.Names +import Diagrams.Path + import Diagrams.TwoD.Types import Diagrams.TwoD.Ellipse import Diagrams.TwoD.Size (size2D) import Diagrams.TwoD.Text +import Diagrams.TwoD.Path import Diagrams.Attributes import Diagrams.Util import Control.Arrow (second) -import Data.Monoid +import Data.Semigroup +import Data.Default import Data.AffineSpace ((.-.)) +import Data.VectorSpace ((^*)) import qualified Data.Map as M import Data.Colour.Names +import Data.Colour (Colour) ------------------------------------------------------------ -- Marking the origin ------------------------------------------------------------ -- | Mark the origin of a diagram by placing a red dot 1/50th its size. -showOrigin :: (Renderable Ellipse b, Backend b R2, Monoid m) - => AnnDiagram b R2 m -> AnnDiagram b R2 m -showOrigin d = o <> d - where o = circle (max (w/50) (h/50)) - # fc red +showOrigin :: (Renderable (Path R2) b, Backend b R2, Monoid' m) + => QDiagram b R2 m -> QDiagram b R2 m +showOrigin = showOrigin' def + +-- | Mark the origin of a diagram, with control over colour and scale +-- of marker dot. +showOrigin' :: (Renderable (Path R2) b, Backend b R2, Monoid' m) + => OriginOpts -> QDiagram b R2 m -> QDiagram b R2 m +showOrigin' oo d = o <> d + where o = stroke (circle sz) + # fc (oColor oo) # lw 0 # fmap (const mempty) - (w,h) = size2D d + (w,h) = size2D d ^* oScale oo + sz = maximum [w, h, oMinSize oo] --- data OriginOpts b m = OriginOpts { oDia :: AnnDiagram b R2 m --- , oScale :: Double --- } +data OriginOpts = OriginOpts { oColor :: Colour Double + , oScale :: Double + , oMinSize :: Double + } --- showOrigin' (OriginOpts o s) d = o' <> d --- where o' = o # scale (max (w * s) (h * s)) --- (w,h) = size2D d +instance Default OriginOpts where + def = OriginOpts red (1/50) 0.001 ------------------------------------------------------------ @@ -63,15 +78,16 @@ ------------------------------------------------------------ showLabels :: (Renderable Text b, Backend b R2) - => AnnDiagram b R2 m -> AnnDiagram b R2 Any -showLabels d = (mconcat + => QDiagram b R2 m -> QDiagram b R2 Any +showLabels d = + ( mconcat . map (\(n,p) -> text (show n) # translate (p .-. origin)) . concatMap (\(n,ps) -> zip (repeat n) ps) - . (map . second . map) fst + . (map . second . map) location . M.assocs - $ m) - `atop` - (fmap (const (Any False)) d) + $ m + ) <> + fmap (const (Any False)) d where NameMap m = names d @@ -81,7 +97,7 @@ -- (or any combinators implemented in terms of 'beside', like '(|||)' -- or '(===)'). --- showSep :: AnnDiagram b R2 m -> AnnDiagram b R2 m +-- showSep :: QDiagram b R2 m -> QDiagram b R2 m -- showSep d = s <> d -- where ... = case d of --- AnnDiagram (Branch u ds children) -> ... +-- QDiagram (Branch u ds children) -> ... diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -3,6 +3,7 @@ , DeriveDataTypeable , GeneralizedNewtypeDeriving , TypeFamilies + , ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -40,7 +41,7 @@ import Graphics.Rendering.Diagrams -import Math.Tau +import Diagrams.Util (tau) import Diagrams.Segment import Diagrams.Path @@ -75,7 +76,7 @@ => Path R2 -> Diagram b R2 stroke = stroke' (def :: StrokeOpts ()) -instance Renderable (Path R2) b => PathLike (AnnDiagram b R2 Any) where +instance Renderable (Path R2) b => PathLike (QDiagram b R2 Any) where pathLike st cl segs = stroke $ pathLike st cl segs -- | A variant of 'stroke' that takes an extra record of options to @@ -87,8 +88,8 @@ -- ... }@ syntax may be used. stroke' :: (Renderable (Path R2) b, IsName a) => StrokeOpts a -> Path R2 -> Diagram b R2 stroke' opts p - = mkAD (Prim p) - (getBounds p) + = mkQD (Prim p) + (getEnvelope p) (fromNames . concat $ zipWith zip (vertexNames opts) (pathVertices p)) (Query $ Any . flip (runFillRule (queryFillRule opts)) p) @@ -183,7 +184,7 @@ fillRule = applyAttr . FillRuleA . Last cross :: R2 -> R2 -> Double -cross (x,y) (x',y') = x * y' - y * x' +cross (unr2 -> (x,y)) (unr2 -> (x',y')) = x * y' - y * x' -- XXX link to more info on this @@ -214,31 +215,35 @@ -- open trails have no inside or outside, so don't contribute crossings trailCrossings _ (_, t) | not (isClosed t) = 0 -trailCrossings p@(P (x,y)) (start, tr) +trailCrossings p@(unp2 -> (x,y)) (start, tr) = sum . map test $ fixTrail start tr where - test (FLinear a@(P (_,ay)) b@(P (_,by))) + test (FLinear a@(unp2 -> (_,ay)) b@(unp2 -> (_,by))) | ay <= y && by > y && isLeft a b > 0 = 1 | by <= y && ay > y && isLeft a b < 0 = -1 | otherwise = 0 - test c@(FCubic (P x1@(_,x1y)) (P c1@(_,c1y)) (P c2@(_,c2y)) (P x2@(_,x2y))) = + test c@(FCubic (unp2 -> x1@(_,x1y)) + (unp2 -> c1@(_,c1y)) + (unp2 -> c2@(_,c2y)) + (unp2 -> x2@(_,x2y)) + ) = sum . map testT $ ts where ts = filter (liftA2 (&&) (>=0) (<=1)) $ cubForm (- x1y + 3*c1y - 3*c2y + x2y) ( 3*x1y - 6*c1y + 3*c2y) (-3*x1y + 3*c1y) (x1y - y) - testT t = let (P (px,_)) = c `fAtParam` t + testT t = let (unp2 -> (px,_)) = c `fAtParam` t in if px > x then signFromDerivAt t else 0 signFromDerivAt t = let (dx,dy) = (3*t*t) *^ ((-1)*^x1 ^+^ 3*^c1 ^-^ 3*^c2 ^+^ x2) ^+^ (2*t) *^ (3*^x1 ^-^ 6*^c1 ^+^ 3*^c2) ^+^ ((-3)*^x1 ^+^ 3*^c1) ang = atan2 dy dx - in case () of _ | (0 < ang && ang < tau/2 && t < 1) -> 1 - | (-tau/2 < ang && ang < 0 && t > 0) -> -1 - | otherwise -> 0 + in case () of _ | 0 < ang && ang < tau/2 && t < 1 -> 1 + | -tau/2 < ang && ang < 0 && t > 0 -> -1 + | otherwise -> 0 isLeft a b = cross (b .-. a) (p .-. a) @@ -265,11 +270,11 @@ -- * Only the parts of the diagram which lie in the interior of the -- path will be drawn. -- --- * The bounding function of the diagram is unaffected. +-- * The envelope of the diagram is unaffected. clipBy :: (HasStyle a, V a ~ R2) => Path R2 -> a -> a clipBy = applyTAttr . Clip . (:[]) -- XXX Should include a 'clipTo' function which clips a diagram AND --- restricts its bounding function. It will have to take a *pointwise --- minimum* of the diagram's current bounding function and the path's --- bounding function. Not sure of the best way to do this at the moment. +-- restricts its envelope. It will have to take a *pointwise minimum* +-- of the diagram's current envelope and the path's envelope. Not +-- sure of the best way to do this at the moment. 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 @@ -2,6 +2,7 @@ , ScopedTypeVariables , DeriveFunctor , ExistentialQuantification + , ViewPatterns #-} ----------------------------------------------------------------------------- @@ -11,7 +12,8 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- General API for creating various types of polygons. +-- This module defines a general API for creating various types of +-- polygons. -- ----------------------------------------------------------------------------- @@ -40,8 +42,6 @@ , GraphPart(..) , orbits, mkGraph - -- * Utility - , centroid ) where import Data.Ord (comparing) @@ -49,17 +49,13 @@ import Data.Maybe (catMaybes) import Data.Monoid (mconcat) -import Math.Tau - -import Control.Arrow ((&&&)) import Control.Monad (forM, liftM) import Control.Monad.ST (runST, ST) import Data.Array.ST (STUArray, newArray, readArray, writeArray) -import Control.Newtype (pack, unpack) import Data.AffineSpace ((.-.), (.+^)) -import Data.VectorSpace (sumV, magnitude, normalized, project, (^/), (<.>), (^*)) +import Data.VectorSpace (magnitude, normalized, project, (<.>), (^*)) import Data.Default import Graphics.Rendering.Diagrams @@ -68,7 +64,8 @@ import Diagrams.TwoD.Transform import Diagrams.TwoD.Vector (unitX, unitY, unit_Y) import Diagrams.Path -import Diagrams.Util ((#)) +import Diagrams.Points (centroid) +import Diagrams.Util ((#), tau) -- | Method used to determine the vertices of a polygon. data PolyType = forall a. Angle a => PolyPolar [a] [Double] @@ -179,7 +176,7 @@ -- | Generate the vertices of a polygon specified by polar data -- (central angles and radii). See 'PolyPolar'. polyPolarVs :: Angle a => [a] -> [Double] -> [P2] -polyPolarVs ans ls = zipWith (\a l -> P . rotate a . scale l $ unitX) +polyPolarVs ans ls = zipWith (\a l -> rotate a . scale l $ p2 (1,0)) (scanl (+) 0 ans) ls @@ -213,20 +210,15 @@ where (n1,x,n2) = maximumBy (comparing (distAlong v . sndOf3)) (zip3 (tail xs ++ take 1 xs) xs (last xs : init xs)) - distAlong w (P p) = signum (w <.> p) * magnitude (project w p) + distAlong w ((.-. origin) -> p) = signum (w <.> p) * magnitude (project w p) x' = maximumBy (comparing (distAlong v)) [n1, n2] e = x' .-. x th = Rad $ acos ((e <.> normalized v) / magnitude e) a | rightTurn (x .+^ v) x x' = tau/4 - th | otherwise = th - tau/4 sndOf3 (_,b,_) = b - rightTurn (P (x1,y1)) (P (x2, y2)) (P (x3,y3)) = + rightTurn (unp2 -> (x1,y1)) (unp2 -> (x2, y2)) (unp2 -> (x3,y3)) = (x2 - x1)*(y3 - y1) - (y2 - y1)*(x3-x1) < 0 - --- | The centroid of a set of /n/ points is the sum of vertices --- divided by /n/. -centroid :: [P2] -> P2 -centroid = pack . uncurry (^/) . (sumV &&& (fromIntegral . length)) . map unpack ------------------------------------------------------------ -- Function graphs diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies , FlexibleContexts + , ViewPatterns #-} ----------------------------------------------------------------------------- @@ -39,7 +40,8 @@ -- * Other shapes , roundedRect - + , RoundedRectOpts(..) + , roundedRect' ) where import Graphics.Rendering.Diagrams @@ -53,16 +55,16 @@ import Diagrams.Util -import Data.Monoid -import Data.VectorSpace +import Data.Default +import Data.Semigroup -- | Create a centered horizontal (L-R) line of the given length. hrule :: (PathLike p, V p ~ R2) => Double -> p -hrule d = pathLike (P (-d/2,0)) False [Linear (d,0)] +hrule d = pathLike (p2 (-d/2,0)) False [Linear (r2 (d,0))] -- | Create a centered vertical (T-B) line of the given length. vrule :: (PathLike p, V p ~ R2) => Double -> p -vrule d = pathLike (P (0,d/2)) False [Linear (0,-d)] +vrule d = pathLike (p2 (0,d/2)) False [Linear (r2 (0,-d))] -- | A sqaure with its center at the origin and sides of length 1, -- oriented parallel to the axes. @@ -147,35 +149,67 @@ -- Other shapes ------------------------------------------ ------------------------------------------------------------ --- | @roundedRect v r@ generates a closed trail, or closed path --- centered at the origin, of an axis-aligned rectangle with diagonal --- @v@ and circular rounded corners of radius @r@. @r@ must be --- between @0@ and half the smaller dimension of @v@, inclusive; smaller or --- larger values of @r@ will be treated as @0@ or half the smaller --- dimension of @v@, respectively. The trail or path begins with the --- right edge and proceeds counterclockwise. -roundedRect :: (PathLike p, V p ~ R2) => R2 -> Double -> p -roundedRect v r = pathLike (P (xOff/2 + r', -yOff/2)) True - . trailSegments - $ seg (0,yOff) - <> mkCorner 0 - <> seg (-xOff,0) - <> mkCorner 1 - <> seg (0, -yOff) - <> mkCorner 2 - <> seg (xOff,0) - <> mkCorner 3 - where seg = fromOffsets . (:[]) - r' = clamp r 0 maxR - maxR = uncurry min v / 2 - (xOff,yOff) = v ^-^ (2*r', 2*r') - mkCorner k | r' == 0 = mempty - | otherwise = arc (k/4) ((k+1)/4::CircleFrac) # scale r' +-- | @roundedRect w h r@ generates a closed trail, or closed path +-- centered at the origin, of an axis-aligned rectangle with width +-- @w@, height @h@, and circular rounded corners of radius @r@. If +-- @r@ is negative the corner will be cut out in a reverse arc. If +-- the size of @r@ is larger than half the smaller dimension of @w@ +-- and @h@, then it will be reduced to fit in that range, to prevent +-- the corners from overlapping. The trail or path begins with the +-- right edge and proceeds counterclockwise. If you need to specify +-- a different radius for each corner individually, use +-- @roundedRect'@ instead. +roundedRect :: (PathLike p, V p ~ R2) => Double -> Double -> Double -> p +roundedRect w h r = roundedRect' w h (with { radiusTL = r, + radiusBR = r, + radiusTR = r, + radiusBL = r}) --- | @clamp x lo hi@ clamps @x@ to lie between @lo@ and @hi@ --- inclusive. That is, if @lo <= x <= hi@ it returns @x@; if @x < lo@ --- it returns @lo@, and if @hi < x@ it returns @hi@. -clamp :: Ord a => a -> a -> a -> a -clamp x lo hi | x < lo = lo - | x > hi = hi - | otherwise = x +-- | @roundedRect'@ works like @roundedRect@ but allows you to set the radius of +-- each corner indivually, using @RoundedRectOpts@. The default corner radius is 0. +-- Each radius can also be negative, which results in the curves being reversed +-- to be inward instead of outward. +roundedRect' :: (PathLike p, V p ~ R2) => Double -> Double -> RoundedRectOpts -> p +roundedRect' w h opts + = pathLike (p2 (w/2, abs rBR - h/2)) True + . trailSegments + $ seg (0, h - abs rTR - abs rBR) + <> mkCorner 0 rTR + <> seg (abs rTR + abs rTL - w, 0) + <> mkCorner 1 rTL + <> seg (0, abs rTL + abs rBL - h) + <> mkCorner 2 rBL + <> seg (w - abs rBL - abs rBR, 0) + <> mkCorner 3 rBR + where seg = fromOffsets . (:[]) . r2 + diag = sqrt (w * w + h * h) + -- to clamp corner radius, need to compare with other corners that share an + -- edge. If the corners overlap then reduce the largest corner first, as far + -- as 50% of the edge in question. + rTL = clampCnr radiusTR radiusBL radiusBR radiusTL + rBL = clampCnr radiusBR radiusTL radiusTR radiusBL + rTR = clampCnr radiusTL radiusBR radiusBL radiusTR + rBR = clampCnr radiusBL radiusTR radiusTL radiusBR + clampCnr rx ry ro r = let (rx',ry',ro',r') = (rx opts, ry opts, ro opts, r opts) + in clampDiag ro' . clampAdj h ry' . clampAdj w rx' $ r' + -- prevent curves of adjacent corners from overlapping + clampAdj len adj r = if abs r > len/2 + then sign r * max (len/2) (min (len - abs adj) (abs r)) + else r + -- prevent inward curves of diagonally opposite corners from intersecting + clampDiag opp r = if r < 0 && opp < 0 && abs r > diag / 2 + then sign r * max (diag / 2) (min (abs r) (diag + opp)) + else r + sign n = if n < 0 then -1 else 1 + mkCorner k r | r == 0 = mempty + | r < 0 = doArc 3 2 + | otherwise = doArc 0 1 + where doArc d d' = arc ((k+d)/4) ((k+d')/4:: CircleFrac) # scale (abs r) + +data RoundedRectOpts = RoundedRectOpts { radiusTL :: Double + , radiusTR :: Double + , radiusBL :: Double + , radiusBR :: Double + } +instance Default RoundedRectOpts where + def = RoundedRectOpts 0 0 0 0 diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -20,46 +20,50 @@ -- ** Specifying sizes , SizeSpec2D(..) + , mkSizeSpec ) where import Graphics.Rendering.Diagrams import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector import Control.Arrow ((***), (&&&)) +import Control.Applicative ((<$>), liftA2) ------------------------------------------------------------ -- Computing diagram sizes ------------------------------------------------------------ --- | Compute the width of a boundable object. -width :: (Boundable a, V a ~ R2) => a -> Double -width = negate . uncurry (-) . extentX +-- | Compute the width of an enveloped object. +width :: (Enveloped a, V a ~ R2) => a -> Double +width = maybe 0 (negate . uncurry (-)) . extentX --- | Compute the height of a boundable object. -height :: (Boundable a, V a ~ R2) => a -> Double -height = negate . uncurry (-) . extentY +-- | Compute the height of an enveloped object. +height :: (Enveloped a, V a ~ R2) => a -> Double +height = maybe 0 (negate . uncurry (-)) . extentY --- | Compute the width and height of a boundable object. -size2D :: (Boundable a, V a ~ R2) => a -> (Double, Double) +-- | Compute the width and height of an enveloped object. +size2D :: (Enveloped a, V a ~ R2) => a -> (Double, Double) size2D = width &&& height --- | Compute the absolute x-coordinate range of a boundable object in --- R2, in the form (lo,hi). -extentX :: (Boundable a, V a ~ R2) => a -> (Double, Double) -extentX d = (-f (-1,0), f (1,0)) - where f = appBounds $ getBounds d +-- | Compute the absolute x-coordinate range of an enveloped object in +-- R2, in the form (lo,hi). Return @Nothing@ for objects with an +-- empty envelope. +extentX :: (Enveloped a, V a ~ R2) => a -> Maybe (Double, Double) +extentX d = (\f -> (-f unit_X, f unitX)) <$> (appEnvelope . getEnvelope $ d) --- | Compute the absolute y-coordinate range of a boundable object in +-- | Compute the absolute y-coordinate range of an enveloped object in -- R2, in the form (lo,hi). -extentY :: (Boundable a, V a ~ R2) => a -> (Double, Double) -extentY d = (-f (0,-1), f (0,1)) - where f = appBounds $ getBounds d +extentY :: (Enveloped a, V a ~ R2) => a -> Maybe (Double, Double) +extentY d = (\f -> (-f unit_Y, f unitY)) <$> (appEnvelope . getEnvelope $ d) -- | Compute the point at the center (in the x- and y-directions) of a --- boundable object. -center2D :: (Boundable a, V a ~ R2) => a -> P2 -center2D = P . (mid *** mid) . (extentX &&& extentY) - where mid = (/2) . uncurry (+) +-- enveloped object. Return the origin for objects with an empty +-- envelope. +center2D :: (Enveloped a, V a ~ R2) => a -> P2 +center2D = maybe origin (p2 . (mid *** mid)) . mm . (extentX &&& extentY) + where mm = uncurry (liftA2 (,)) + mid = (/2) . uncurry (+) ------------------------------------------------------------ -- Size specifications @@ -73,9 +77,17 @@ | Height Double -- ^ Specify an explicit -- height. The width should be -- determined automatically (so - -- as to preserve aspect ratio) + -- as to preserve aspect ratio). | Dims Double Double -- ^ An explicit specification - -- of both dimensions. + -- of a width and height. | Absolute -- ^ Absolute size: use whatever -- size an object already has; -- do not rescale. + +-- | Create a size specification from a possibly-specified width and +-- height. +mkSizeSpec :: Maybe Double -> Maybe Double -> SizeSpec2D +mkSizeSpec Nothing Nothing = Absolute +mkSizeSpec (Just w) Nothing = Width w +mkSizeSpec Nothing (Just h) = Height h +mkSizeSpec (Just w) (Just h) = Dims w h 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 @@ -2,6 +2,7 @@ , GeneralizedNewtypeDeriving , FlexibleContexts , TypeFamilies + , MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | @@ -16,8 +17,8 @@ module Diagrams.TwoD.Text ( -- * Creating text diagrams - Text(..) - , text + Text(..), TextAlignment(..) + , text, topLeftText, alignedText, baselineText -- * Text attributes -- ** Font family @@ -33,12 +34,10 @@ import Graphics.Rendering.Diagrams import Diagrams.TwoD.Types -import Diagrams.Util import Data.AffineSpace ((.-.)) -import Data.Monoid (mempty) -import Data.Semigroup (Semigroup, Last(..)) +import Data.Semigroup import Data.Typeable @@ -46,58 +45,73 @@ -- Text diagrams ------------------------------------------------------------ --- | A text primitive consists of the string contents along with a --- transformation mapping from the local vector space of the text to --- the vector space in which it is embedded. -data Text = Text T2 String +-- | A text primitive consists of the string contents and alignment +-- specification, along with a transformation mapping from the local +-- vector space of the text to the vector space in which it is +-- embedded. +data Text = Text T2 TextAlignment String type instance V Text = R2 instance Transformable Text where - transform t (Text tt s) = Text (t <> tt) s + transform t (Text tt a s) = Text (t <> tt) a s instance HasOrigin Text where moveOriginTo p = translate (origin .-. p) --- | Create a primitive text diagram from the given string, which --- /takes up no space/. By default, the text is centered with --- respect to its local origin (see 'alignText'). -text :: Renderable Text b => String -> Diagram b R2 -text t = mkAD (Prim (Text mempty t)) - mempty - mempty - mempty +instance Renderable Text NullBackend where + render _ _ = mempty ------------------------------------------------------------- --- Text attributes ------------------------------------------------------------- +-- | @TextAlignment@ specifies the alignment of the text's origin. +data TextAlignment = BaselineText | BoxAlignedText Double Double -{- --------------------------------------------------- --- Alignment +mkText :: Renderable Text b => TextAlignment -> String -> Diagram b R2 +mkText a t = mkQD (Prim (Text mempty a t)) + mempty + mempty + mempty --- | The @TextAlignment@ attribute specifies what alignment should be --- applied to text. Inner @TextAlignment@ attributes override outer --- ones. -newtype TextAlignment = TextAlignment (Last (Alignment R2)) - deriving (Typeable, Semigroup) -instance AttributeClass TextAlignment +-- | Create a primitive text diagram from the given string, with center +-- alignment, equivalent to @alignedText 0.5 0.5@. +-- +-- Note that it /takes up no space/, as text size information is not +-- available. +text :: Renderable Text b => String -> Diagram b R2 +text = alignedText 0.5 0.5 --- | Extract an alignment from a @TextAlignment@ attribute. -getTextAlignment :: TextAlignment -> Alignment R2 -getTextAlignment (TextAlignment (Last a)) = a +-- | 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@. +-- +-- Note that it /takes up no space/. +topLeftText :: Renderable Text b => String -> Diagram b R2 +topLeftText = alignedText 0 1 --- | The default alignment for text is centered. -centeredText :: TextAlignment -centeredText = TextAlignment (Last (asAlignment id)) +-- | Create a primitive text diagram from the given string, with the +-- origin set to a point interpolated within the bounding box. The +-- first parameter varies from 0 (left) to 1 (right), and the second +-- parameter from 0 (bottom) to 1 (top). +-- +-- The height of this box is determined by the font's potential ascent +-- and descent, rather than the height of the particular string. +-- +-- Note that it /takes up no space/. +alignedText :: Renderable Text b => Double -> Double -> String -> Diagram b R2 +alignedText w h = mkText (BoxAlignedText w h) --- | @alignText f@ aligns text by applying the alignment function @f@ --- (any transformation of boundable things with origins may be used; --- for example, 'alignTL' and friends). -alignText :: HasStyle a => (Alignment R2 -> Alignment R2) -> a -> a -alignText = applyAttr . TextAlignment . Last . asAlignment --} +-- | Create a primitive text diagram from the given string, with the +-- origin set to be on the baseline, at the beginning (although not +-- bounding). This is the reference point of showText in the Cairo +-- graphics library. +-- +-- Note that it /takes up no space/. +baselineText :: Renderable Text b => String -> Diagram b R2 +baselineText = mkText BaselineText +------------------------------------------------------------ +-- Text attributes +------------------------------------------------------------ + -------------------------------------------------- -- Font family @@ -145,7 +159,7 @@ -- | 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)) +newtype FontSlantA = FontSlantA (Last FontSlant) deriving (Typeable, Semigroup) instance AttributeClass FontSlantA 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,5 +1,6 @@ {-# LANGUAGE FlexibleContexts , TypeFamilies + , ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -38,16 +39,24 @@ , reflectionX, reflectX , reflectionY, reflectY , reflectionAbout, reflectAbout + + -- * Shears + , shearingX, shearX + , shearingY, shearY + ) where import Graphics.Rendering.Diagrams +import Control.Newtype (over) + import Diagrams.TwoD.Types import Diagrams.TwoD.Size (width, height) import Diagrams.TwoD.Vector (direction) import Diagrams.Transform -import Diagrams.Util +import Data.Semigroup + import Data.AffineSpace import Control.Arrow (first, second) @@ -61,7 +70,7 @@ where r = rot theta <-> rot (-theta) Rad theta = convertAngle ang - rot th (x,y) = (cos th * x - sin th * y, sin th * x + cos th * y) + rot th (unr2 -> (x,y)) = r2 (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 @@ -91,7 +100,7 @@ -- | @rotateAbout p@ is like 'rotate', except it rotates around the -- point @p@ instead of around the local origin. rotateAbout :: (Transformable t, V t ~ R2, Angle a) => P2 -> a -> t -> t -rotateAbout p angle = rotate angle `under` (translation (origin .-. p)) +rotateAbout p angle = rotate angle `under` translation (origin .-. p) -- Scaling ------------------------------------------------- @@ -99,11 +108,10 @@ -- the x (horizontal) direction. scalingX :: Double -> T2 scalingX c = fromLinear s s - where s = first (*c) <-> first (/c) + where s = (over r2 . first) (*c) <-> (over r2 . first) (/c) -- | Scale a diagram by the given factor in the x (horizontal) --- direction. To scale uniformly, use --- 'Graphics.Rendering.Diagrams.Transform.scale'. +-- direction. To scale uniformly, use 'scale'. scaleX :: (Transformable t, V t ~ R2) => Double -> t -> t scaleX = transform . scalingX @@ -111,11 +119,10 @@ -- the y (vertical) direction. scalingY :: Double -> T2 scalingY c = fromLinear s s - where s = second (*c) <-> second (/c) + where s = (over r2 . second) (*c) <-> (over r2 . second) (/c) -- | Scale a diagram by the given factor in the y (vertical) --- direction. To scale uniformly, use --- 'Graphics.Rendering.Diagrams.Transform.scale'. +-- direction. To scale uniformly, use 'scale'. scaleY :: (Transformable t, V t ~ R2) => Double -> t -> t scaleY = transform . scalingY @@ -123,27 +130,26 @@ -- whatever factor required to make its width @w@. @scaleToX@ -- should not be applied to diagrams with a width of 0, such as -- 'vrule'. -scaleToX :: (Boundable t, Transformable t, V t ~ R2) => Double -> t -> t +scaleToX :: (Enveloped t, Transformable t, V t ~ R2) => Double -> t -> t scaleToX w d = scaleX (w / width d) d -- | @scaleToY h@ scales a diagram in the y (vertical) direction by -- whatever factor required to make its height @h@. @scaleToY@ --- should not be applied to diagrams with a width of 0, such as +-- should not be applied to diagrams with a height of 0, such as -- 'hrule'. -scaleToY :: (Boundable t, Transformable t, V t ~ R2) => Double -> t -> t +scaleToY :: (Enveloped t, Transformable t, V t ~ R2) => Double -> t -> t scaleToY h d = scaleY (h / height d) d -- | @scaleUToX w@ scales a diagram /uniformly/ by whatever factor -- required to make its width @w@. @scaleUToX@ should not be -- applied to diagrams with a width of 0, such as 'vrule'. -scaleUToX :: (Boundable t, Transformable t, V t ~ R2) => Double -> t -> t +scaleUToX :: (Enveloped t, Transformable t, V t ~ R2) => Double -> t -> t scaleUToX w d = scale (w / width d) d --- | @scaleUToY h@ scales a diagram in the y (vertical) direction by --- whatever factor required to make its height @h@. @scaleUToY@ --- should not be applied to diagrams with a width of 0, such as --- 'hrule'. -scaleUToY :: (Boundable t, Transformable t, V t ~ R2) => Double -> t -> t +-- | @scaleUToY h@ scales a diagram /uniformly/ by whatever factor +-- required to make its height @h@. @scaleUToY@ should not be applied +-- to diagrams with a height of 0, such as 'hrule'. +scaleUToY :: (Enveloped t, Transformable t, V t ~ R2) => Double -> t -> t scaleUToY h d = scale (h / height d) d -- Translation --------------------------------------------- @@ -151,7 +157,7 @@ -- | Construct a transformation which translates by the given distance -- in the x (horizontal) direction. translationX :: Double -> T2 -translationX x = translation (x,0) +translationX x = translation (r2 (x,0)) -- | Translate a diagram by the given distance in the x (horizontal) -- direction. @@ -161,7 +167,7 @@ -- | Construct a transformation which translates by the given distance -- in the y (vertical) direction. translationY :: Double -> T2 -translationY y = translation (0,y) +translationY y = translation (r2 (0,y)) -- | Translate a diagram by the given distance in the y (vertical) -- direction. @@ -201,3 +207,34 @@ -- the point @p@ and the vector @v@. reflectAbout :: (Transformable t, V t ~ R2) => P2 -> R2 -> t -> t reflectAbout p v = transform (reflectionAbout p v) + +-- Shears -------------------------------------------------- + +-- | @shearingX d@ is the linear transformation which is the identity on +-- y coordinates and sends @(0,1)@ to @(d,1)@. +shearingX :: Double -> T2 +shearingX d = fromLinear (over r2 (sh d) <-> over r2 (sh (-d))) + (over r2 (sh' d) <-> over r2 (sh' (-d))) + where sh k (x, y) = (x+k*y, y) + sh' k = swap . sh k . swap + swap (x,y) = (y,x) + +-- | @shearX d@ performs a shear in the x-direction which sends +-- @(0,1)@ to @(d,1)@. +shearX :: (Transformable t, V t ~ R2) => Double -> t -> t +shearX = transform . shearingX + +-- | @shearingY d@ is the linear transformation which is the identity on +-- x coordinates and sends @(1,0)@ to @(1,d)@. +shearingY :: Double -> T2 +shearingY d = fromLinear (over r2 (sh d) <-> over r2 (sh (-d))) + (over r2 (sh' d) <-> over r2 (sh' (-d))) + where sh k (x,y) = (x, y+k*x) + sh' k = swap . sh k . swap + swap (x,y) = (y,x) + +-- | @shearY d@ performs a shear in the y-direction which sends +-- @(1,0)@ to @(1,d)@. +shearY :: (Transformable t, V t ~ R2) => Double -> t -> t +shearY = transform . shearingY + diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -2,6 +2,9 @@ , TypeSynonymInstances , FlexibleInstances , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , ViewPatterns + , DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -17,8 +20,8 @@ module Diagrams.TwoD.Types ( -- * 2D Euclidean space - R2 - , P2 + R2, r2, unr2 + , P2, p2, unp2 , T2 -- * Angles @@ -28,19 +31,80 @@ ) where import Graphics.Rendering.Diagrams +import Diagrams.Util (tau) -import Math.Tau +import Control.Newtype +import Data.Basis +import Data.NumInstances () +import Data.VectorSpace + +import Data.Typeable + ------------------------------------------------------------ -- 2D Euclidean space --- | The two-dimensional Euclidean vector space R^2. -type R2 = (Double, Double) +-- | The two-dimensional Euclidean vector space R^2. This type is +-- intentionally abstract. +-- +-- * To construct a vector, use 'r2'. +-- +-- * To construct the vector from the origin to a point @p@, use +-- @p .-. origin@. +-- +-- * To convert a vector @v@ into the point obtained by following +-- @v@ from the origin, use @'origin' '.+^' v@. +-- +-- * To convert a vector back into a pair of components, use 'unv2'. +newtype R2 = R2 { unR2 :: (Double, Double) } + deriving (AdditiveGroup, Eq, Ord, Show, Read, Typeable, Num, Fractional) +instance Newtype R2 (Double, Double) where + pack = R2 + unpack = unR2 + +-- | Construct a 2D vector from a pair of components. +r2 :: (Double, Double) -> R2 +r2 = pack + +-- | Convert a 2D vector back into a pair of components. +unr2 :: R2 -> (Double, Double) +unr2 = unpack + type instance V R2 = R2 --- | Points in R^2. +instance VectorSpace R2 where + type Scalar R2 = Double + (*^) = over R2 . (*^) + +instance HasBasis R2 where + type Basis R2 = Either () () -- = Basis (Double, Double) + basisValue = R2 . basisValue + decompose = decompose . unR2 + decompose' = decompose' . unR2 + +instance InnerSpace R2 where + (unR2 -> vec1) <.> (unR2 -> vec2) = vec1 <.> vec2 + +-- | Points in R^2. This type is intentionally abstract. +-- +-- * To construct a point, use 'p2'. +-- +-- * To construct a point from a vector @v@, use @origin .+^ v@. +-- +-- * To convert a point @p@ into the vector from the origin to @p@, +-- use @p '.-.' 'origin'@. +-- +-- * To convert a point back into a pair of coordinates, use 'unp2'. type P2 = Point R2 + +-- | Construct a 2D point from a pair of coordinates. +p2 :: (Double, Double) -> P2 +p2 = pack . pack + +-- | Convert a 2D point back into a pair of coordinates. +unp2 :: P2 -> (Double, Double) +unp2 = unpack . unpack -- | Transformations in R^2. type T2 = Transformation R2 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 @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts , TypeFamilies + , ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -23,29 +24,29 @@ -- | The unit vector in the positive X direction. unitX :: R2 -unitX = (1,0) +unitX = r2 (1,0) -- | The unit vector in the positive Y direction. unitY :: R2 -unitY = (0,1) +unitY = r2 (0,1) -- | The unit vector in the negative X direction. unit_X :: R2 -unit_X = (-1,0) +unit_X = r2 (-1,0) -- | The unit vector in the negative Y direction. unit_Y :: R2 -unit_Y = (0,-1) +unit_Y = r2 (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 (x,y) = convertAngle . Rad $ atan2 y x +direction (unr2 -> (x,y)) = convertAngle . Rad $ atan2 y x -- | Convert an angle into a unit vector pointing in that direction. fromDirection :: Angle a => a -> R2 -fromDirection a = (cos a', sin a') +fromDirection a = r2 (cos a', sin a') where Rad a' = convertAngle a -- | A convenient synonym for 'fromDirection'. diff --git a/src/Diagrams/Util.hs b/src/Diagrams/Util.hs --- a/src/Diagrams/Util.hs +++ b/src/Diagrams/Util.hs @@ -13,12 +13,16 @@ ( -- * Utilities for users with - , (<>) , applyAll , (#) + , iterateN + + , tau + -- * Internal utilities , Proxy(..) + , foldB ) where @@ -47,40 +51,6 @@ with :: Default d => d with = def --- | A convenient infix operator for 'mappend' (monoidal combination). --- Many things in the diagrams library can be combined using @(\<\>)@, --- with the meaning dependent on the types of things being combined. --- For example: --- --- * The combination of two transformations @t1 \<\> t2@ is a --- transformation which performs first @t2@, then @t1@. --- --- * Combining two diagrams @d1 \<\> d2@ results in a superimposed --- diagram with @d1@ on top of @d2@ (with their local origins aligned). --- --- * Combining two paths works in the same way as combining diagrams. --- --- * Combining two trails results in a longer trail composed of the --- first trail followed by the second. --- --- * Combining two styles, @s1 \<\> s2@, results in a style with --- combined attributes from both, biased to @s2@ when @s1@ and --- @s2@ contain attributes of the same type. --- --- * Combining two @'AlphaColour' Double@s results in a composited --- color (the color that results when objects of the two colors are --- superimposed). --- --- In addition, 'mempty' always represents a suitably \"trivial\" --- object which is the identity for @(\<\>)@ (that is, @mempty \<\> --- x == x \<\> mempty == x@). 'mempty' can stand for the identity --- transformation; the empty diagram, path, trail, or style; the --- completely transparent color; and so on. -(<>) :: Monoid m => m -> m -> m -(<>) = mappend - -infixr 5 <> - -- | @applyAll@ takes a list of functions and applies them all to a -- value, in sequence from the last function in the list to the first. -- For example, @applyAll [f1, f2, f3] a == f1 . f2 . f3 $ a@. @@ -96,6 +66,40 @@ (#) :: a -> (a -> b) -> b (#) = flip ($) +-- | @iterateN n f x@ returns the list of the first @n@ iterates of +-- @f@ starting at @x@, that is, the list @[x, f x, f (f x), ...]@ +-- of length @n@. (Note that the last element of the list will be +-- @f@ applied to @x@ @(n-1)@ times.) +iterateN :: Int -> (a -> a) -> a -> [a] +iterateN n f = take n . iterate f + +-- | The circle constant, the ratio of a circle's circumference to its +-- /radius/. Note that @pi = tau/2@. +-- +-- For more information and a well-reasoned argument why we should +-- all be using tau instead of pi, see /The Tau Manifesto/, +-- . +-- +-- To hear what it sounds like (and to easily memorize the first 30 +-- digits or so), try . +tau :: Floating a => a +tau = 2*pi + -- | A value of @Proxy a@ carries no information; it's used only to -- fix the type @a@. data Proxy a = Proxy + +-- | Given an associative binary operation and a default value to use +-- in the case of an empty list, perform a /balanced/ fold over a +-- list. For example, +-- +-- > foldB (+) z [a,b,c,d,e,f] == ((a+b) + (c+d)) + (e+f) +-- +foldB :: (a -> a -> a) -> a -> [a] -> a +foldB _ z [] = z +foldB f _ as = foldB' as + where foldB' [x] = x + foldB' xs = foldB' (go xs) + go [] = [] + go [x] = [x] + go (x1:x2:xs) = f x1 x2 : go xs