diagrams-lib 0.4.0.1 → 0.5

raw patch · 37 files changed

+1499/−722 lines, 37 filesdep +activedep −taudep ~arraydep ~basedep ~colourPVP ok

version bump matches the API change (PVP)

Dependencies added: active

Dependencies removed: tau

Dependency ranges changed: array, base, colour, diagrams-core, vector-space

API changes (from Hackage documentation)

Files

• CHANGES +170/−37
• LICENSE +4/−1
• README +0/−8
• diagrams-lib.cabal +12/−9
• src/Diagrams/Align.hs +60/−24
• src/Diagrams/Animation.hs +125/−0
• src/Diagrams/Animation/Active.hs +101/−0
• src/Diagrams/Backend/Show.hs +2/−9
• src/Diagrams/BoundingBox.hs +89/−31
• src/Diagrams/Combinators.hs +89/−98
• src/Diagrams/CubicSpline.hs +11/−2
• src/Diagrams/CubicSpline/Internal.hs +18/−10
• src/Diagrams/Path.hs +69/−29
• src/Diagrams/Points.hs +30/−0
• src/Diagrams/Prelude.hs +18/−7
• src/Diagrams/Segment.hs +41/−33
• src/Diagrams/Solve.hs +1/−1
• src/Diagrams/ThreeD/Shapes.hs +6/−6
• src/Diagrams/ThreeD/Types.hs +45/−3
• src/Diagrams/Transform.hs +1/−1
• src/Diagrams/TwoD.hs +21/−11
• src/Diagrams/TwoD/Adjust.hs +53/−28
• src/Diagrams/TwoD/Align.hs +17/−17
• src/Diagrams/TwoD/Arc.hs +12/−17
• src/Diagrams/TwoD/Combinators.hs +84/−25
• src/Diagrams/TwoD/Ellipse.hs +10/−87
• src/Diagrams/TwoD/Image.hs +7/−4
• src/Diagrams/TwoD/Model.hs +38/−22
• src/Diagrams/TwoD/Path.hs +21/−16
• src/Diagrams/TwoD/Polygons.hs +9/−17
• src/Diagrams/TwoD/Shapes.hs +70/−36
• src/Diagrams/TwoD/Size.hs +35/−23
• src/Diagrams/TwoD/Text.hs +57/−43
• src/Diagrams/TwoD/Transform.hs +57/−20
• src/Diagrams/TwoD/Types.hs +70/−6
• src/Diagrams/TwoD/Vector.hs +7/−6
• src/Diagrams/Util.hs +39/−35

@@ -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

@@ -1,6 +1,9 @@-Copyright (c) 2011 diagrams-lib team:+Copyright (c) 2011-2012 diagrams-lib team: +  Peter Hall <peter.hall@memorphic.com>   Claude Heiland-Allen <claudiusmaximus@goto10.org>+  Ian Ross <ian@skybluetrades.net>+  Michael Sloan <mgsloan@gmail.com>   Kanchalai Suveepattananont <ksuvee@seas.upenn.edu>   Scott Walck <walck@lvc.edu>   Ryan Yates <fryguybob@gmail.com>

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -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 <http://en.wikipedia.org/wiki/Sherman-Morrison_formula>.---   This code is based on /Numerical Recpies in C/'s "cyclic" function in section 2.7.+--   of the Sherman-Morrison formula <http://en.wikipedia.org/wiki/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]

@@ -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.

@@ -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

@@ -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

@@ -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'.

@@ -17,7 +17,7 @@ import Data.List (maximumBy) import Data.Ord (comparing) -import Math.Tau+import Diagrams.Util (tau)  ------------------------------------------------------------ -- Quadratic formula

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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.

@@ -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)

@@ -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

@@ -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

@@ -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) -> ...

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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 

@@ -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+

@@ -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

@@ -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'.

@@ -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/,+--   <http://tauday.com/>.+--+--   To hear what it sounds like (and to easily memorize the first 30+--   digits or so), try <http://youtu.be/3174T-3-59Q>.+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