packages feed

diagrams-lib (empty) → 0.1

raw patch · 23 files changed

+2478/−0 lines, 23 filesdep +basedep +colourdep +containerssetup-changed

Dependencies added: base, colour, containers, data-default, diagrams-core, pretty, vector-space

Files

+ LICENSE view
@@ -0,0 +1,35 @@+Copyright 2011 diagrams-lib team:++  Kanchalai Suveepattananont <ksuvee@seas.upenn.edu>+  Scott Walck <walck@lvc.edu>+  Ryan Yates <fryguybob@gmail.com>+  Brent Yorgey <byorgey@cis.upenn.edu>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Brent Yorgey nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ diagrams-lib.cabal view
@@ -0,0 +1,54 @@+Name:                diagrams-lib+Version:             0.1+Synopsis:            Embedded domain-specific language for declarative graphics+Description:         Diagrams is a flexible, extensible EDSL for creating+                     graphics of many types.  Graphics can be created+                     in arbitrary vector spaces and rendered with+                     multiple backends.  diagrams-lib provides a+                     standard library of primitives and operations for+                     creating diagrams.  To get started using it, see+                     "Diagrams.Prelude".+Homepage:            http://code.google.com/p/diagrams/+License:             BSD3+License-file:        LICENSE+Author:              Brent Yorgey+Maintainer:          byorgey@cis.upenn.edu+Stability:           Experimental+Category:            Graphics+Build-type:          Simple+Cabal-version:       >=1.6+Tested-with:         GHC == 6.12.3, GHC >= 7.0.2 && <= 7.0.3+Source-repository head+  type:     darcs+  location: http://patch-tag.com/r/byorgey/diagrams-lib++Library+  Exposed-modules:     Diagrams.Prelude,+                       Diagrams.Align,+                       Diagrams.Combinators,+                       Diagrams.Attributes,+                       Diagrams.Segment,+                       Diagrams.Path,+                       Diagrams.Solve,+                       Diagrams.TwoD,+                       Diagrams.TwoD.Types,+                       Diagrams.TwoD.Align,+                       Diagrams.TwoD.Combinators,+                       Diagrams.TwoD.Transform,+                       Diagrams.TwoD.Ellipse,+                       Diagrams.TwoD.Arc,+                       Diagrams.TwoD.Path,+                       Diagrams.TwoD.Shapes,+                       Diagrams.TwoD.Util,+                       Diagrams.TwoD.Model,+--                       Diagrams.Animation,+                       Diagrams.Util,+                       Diagrams.Backend.Show+  Build-depends:       base >= 4.2 && < 4.4,+                       containers >= 0.3 && < 0.5,+                       diagrams-core >= 0.1 && < 0.2,+                       vector-space >= 0.7 && < 0.8,+                       colour >= 2.3.1 && < 2.4,+                       data-default >= 0.2 && < 0.3,+                       pretty >= 1.0.1.2 && < 1.1+  Hs-source-dirs:      src
+ src/Diagrams/Align.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TypeFamilies+           , FlexibleContexts+  #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.Align+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- 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.+--+-----------------------------------------------------------------------------++module Diagrams.Align+       ( align, alignBy+       , center+       ) where++import Graphics.Rendering.Diagrams++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+++-- XXX need a better, more intuitive description of alignBy++-- | @align v d a@ moves the origin of @a@ to a distance of @d*r@ from+--   the center along @v@, where @r@ is the radius along @v@.  Hence+--   @align v 0@ centers along @v@, and @align v 1@ moves the origin+--   in the direction of @v@ to the very edge of the bounding region.+alignBy :: (HasOrigin a, Boundable a) => V a -> Rational -> a -> a+alignBy v d a = moveOriginTo (alerp (boundary (negateV v) a)+                                    (boundary v a)+                                    ((fromRational d + 1) / 2))+                             a++-- | @center v@ centers a boundable object along the direction of @v@.+center :: (HasOrigin a, Boundable a) => V a -> a -> a+center v = alignBy v 0
+ src/Diagrams/Attributes.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE DeriveDataTypeable+           , ExistentialQuantification+  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.Attributes+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Diagrams may have /attributes/ which affect the way they are+-- rendered.  This module defines some common attributes; particular+-- backends may also define more backend-specific attributes.+--+-----------------------------------------------------------------------------++module Diagrams.Attributes (+  -- * Color+  -- $color++    Color(..), SomeColor(..)++  -- ** Line color+  , LineColor(..), lineColor, lc, lcA++  -- ** Fill color+  , FillColor(..), fillColor, fc, fcA++  -- * Lines+  , LineWidth(..), lineWidth, lw+  , LineCap(..), lineCap+  , LineJoin(..), lineJoin+  , Dashing(..), dashing++  ) where++import Graphics.Rendering.Diagrams++import Data.Colour+import qualified Data.Colour.SRGB as RGB++import Data.Typeable++------------------------------------------------------------+--  Color  -------------------------------------------------+------------------------------------------------------------++-- $color+-- Diagrams outsources all things color-related to Russell O\'Connor\'s+-- very nice colour package+-- (<http://hackage.haskell.org/package/colour>).  For starters, it+-- provides a large collection of standard color names.  However, it+-- also provides a rich set of combinators for combining and+-- manipulating colors; see its documentation for more information.++-- | The 'Color' type class encompasses color representations which+--   can be used by the Diagrams library.  Instances are provided for+--   both the 'Data.Colour.Colour' and 'Data.Colour.AlphaColour' types+--   from the "Data.Colour" library.+class Color c where+  -- | Convert a color to red, green, blue, and alpha channels in the+  --   range [0,1].+  colorToRGBA :: c -> (Double,Double,Double,Double)++-- | An existential wrapper for instances of the 'Color' class.+data SomeColor = forall c. Color c => SomeColor c+  deriving Typeable++-- | The color with which lines (strokes) are drawn.+newtype LineColor = LineColor SomeColor+  deriving Typeable+instance AttributeClass LineColor++-- | Set the line (stroke) color.  This function is polymorphic in the+--   color type (so it can be used with either 'Colour' or+--   'AlphaColour'), but this can sometimes create problems for type+--   inference, so the 'lc' and 'lcA' variants are provided with more+--   concrete types.+lineColor :: (Color c, HasStyle a) => c -> a -> a+lineColor = applyAttr . LineColor . SomeColor++-- | A synonym for 'lineColor', specialized to @'Colour' Double@+--   (i.e. opaque colors).+lc :: HasStyle a => Colour Double -> a -> a+lc = lineColor++-- | A synonym for 'lineColor', specialized to @'AlphaColour' Double@+--   (i.e. colors with transparency).+lcA :: HasStyle a => AlphaColour Double -> a -> a+lcA = lineColor++-- | The color with which shapes are filled.+newtype FillColor = FillColor SomeColor+  deriving Typeable+instance AttributeClass FillColor++-- | Set the fill color.  This function is polymorphic in the color+--   type (so it can be used with either 'Colour' or 'AlphaColour'),+--   but this can sometimes create problems for type inference, so the+--   'fc' and 'fcA' variants are provided with more concrete types.+fillColor :: (Color c, HasStyle a) => c -> a -> a+fillColor = applyAttr . FillColor . SomeColor++-- | A synonym for 'fillColor', specialized to @'Colour' Double@+--   (i.e. opaque colors).+fc :: HasStyle a => Colour Double -> a -> a+fc = fillColor++-- | A synonym for 'fillColor', specialized to @'AlphaColour' Double@+--   (i.e. colors with transparency).+fcA :: HasStyle a => AlphaColour Double -> a -> a+fcA = fillColor++instance (Floating a, Real a) => Color (Colour a) where+  colorToRGBA col = (r,g,b,1)+    where c' = RGB.toSRGB . colourConvert $ col+          r  = RGB.channelRed c'+          g  = RGB.channelGreen c'+          b  = RGB.channelBlue c'++instance (Floating a, Real a) => Color (AlphaColour a) where+  colorToRGBA col = (r,g,b,a)+    where col' = alphaColourConvert col+          a  = alphaChannel col'+          c' = RGB.toSRGB . alphaToColour $ col'+          r  = RGB.channelRed c'+          g  = RGB.channelGreen c'+          b  = RGB.channelBlue c'++instance Color SomeColor where+  colorToRGBA (SomeColor c) = colorToRGBA c++instance Color LineColor where+  colorToRGBA (LineColor c) = colorToRGBA c++instance Color FillColor where+  colorToRGBA (FillColor c) = colorToRGBA c++alphaToColour :: (Floating a, Ord a, Fractional a) => AlphaColour a -> Colour a+alphaToColour ac | alphaChannel ac == 0 = ac `over` black+                 | otherwise = darken (recip (alphaChannel ac)) (ac `over` black)+++------------------------------------------------------------+--  Lines and stuff    -------------------------------------+------------------------------------------------------------++-- | The width of lines.  By default, the line width is measured with+--   respect to the /final/ coordinate system of a rendered diagram,+--   as opposed to the local coordinate systems in effect at the time+--   the line width was set for various subdiagrams.  This is so that+--   it is easy to combine a variety of shapes (some created by+--   scaling) and have them all drawn using a consistent line width.+--   However, sometimes it is desirable for scaling to affect line+--   width; the 'freeze' operation is provided for this purpose.  The+--   line width of frozen diagrams is affected by transformations.+newtype LineWidth = LineWidth Double+  deriving Typeable+instance AttributeClass LineWidth++-- | Set the line (stroke) width.+lineWidth :: HasStyle a => Double -> a -> a+lineWidth = applyAttr . LineWidth++-- | A convenient synonym for 'lineWidth'.+lw :: HasStyle a => Double -> a -> a+lw = lineWidth+++-- | What sort of shape should be placed at the endpoints of lines?+data LineCap = LineCapButt   -- ^ Lines end precisely at their endpoints.+             | LineCapRound  -- ^ Lines are capped with semicircles+                             --   centered on endpoints.+             | LineCapSquare -- ^ Lines are capped with a squares+                             --   centered on endpoints.+  deriving (Eq,Show,Typeable)+instance AttributeClass LineCap++-- | Set the line end cap attribute.+lineCap :: HasStyle a => LineCap -> a -> a+lineCap = applyAttr+++-- | How should the join points between line segments be drawn?+data LineJoin = LineJoinMiter    -- ^ Use a \"miter\" shape (whatever that is).+              | LineJoinRound    -- ^ Use rounded join points.+              | LineJoinBevel    -- ^ Use a \"bevel\" shape (whatever+                                 --   that is).  Are these...+                                 --   carpentry terms?+  deriving (Eq,Show,Typeable)+instance AttributeClass LineJoin++-- | Set the segment join style.+lineJoin :: HasStyle a => LineJoin -> a -> a+lineJoin = applyAttr+++-- | Create lines that are dashing... er, dashed.+data Dashing = Dashing [Double] Double+  deriving Typeable+instance AttributeClass Dashing++-- | Set the line dashing style.+dashing :: HasStyle a =>+           [Double]  -- ^ A list specifying alternate lengths of on+                     --   and off portions of the stroke.  The empty+                     --   list indicates no dashing.+        -> Double    -- ^ An offset into the dash pattern at which the+                     --   stroke should start.+        -> a -> a+dashing ds offs = applyAttr (Dashing ds offs)
+ src/Diagrams/Backend/Show.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE FlexibleInstances+           , FlexibleContexts+           , MultiParamTypeClasses+           , ScopedTypeVariables+           , TypeSynonymInstances+           , TypeFamilies+           , GeneralizedNewtypeDeriving+  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.Backend.Show+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- A simple Show-based diagrams backend, for testing purposes.+--+-----------------------------------------------------------------------------+module Diagrams.Backend.Show where++import Diagrams.Prelude++import Diagrams.TwoD.Ellipse++import Data.Basis++import Text.PrettyPrint (Doc, empty, ($+$), parens, hsep, text, nest)+import qualified Text.PrettyPrint as PP++import Data.List (transpose)++-- | Token for identifying this backend.+data ShowBackend = ShowBackend++instance HasLinearMap v => Backend ShowBackend v where+  data Render  ShowBackend v = SR Doc+  type Result  ShowBackend v = String+  data Options ShowBackend v = SBOpt++  withStyle _ _ _ r = r -- XXX FIXME++  doRender _ _ (SR r) = PP.render r++instance Monoid (Render ShowBackend v) where+  mempty = SR empty+  (SR d1) `mappend` (SR d2) = SR (d1 $+$ d2)++renderTransf :: forall v. (Num (Scalar v), HasLinearMap v)+             => Transformation v -> Doc+renderTransf t = renderMat mat+  where tr :: v+        tr    = transl t+        basis :: [Basis v]+        basis = map fst (decompose tr)+        es :: [v]+        es    = map basisValue basis+        vmat :: [v]+        vmat = map (apply t) es+        mat :: [[Scalar v]]+        mat = map decompV vmat+--        mat' :: [[Scalar v]]+--        mat'  = map (++[0]) mat ++ [decompV tr ++ [1]]+        decompV = map snd . decompose++renderMat :: Show a => [[a]] -> Doc+renderMat = PP.vcat . map renderRow . transpose+  where renderRow = parens . hsep . map (text . show)++instance Renderable Ellipse ShowBackend where+  render _ (Ellipse t) = SR $ text "Ellipse (" $+$+                                (nest 2 (renderTransf t)) $+$+                              text ")"++instance (Show v, HasLinearMap v) => Renderable (Segment v) ShowBackend where+  render _ s = SR $ text (show s)++instance (Show v, HasLinearMap v) => Renderable (Trail v) ShowBackend where+  render _ t = SR $ text (show t)++instance (Ord v, Show v, HasLinearMap v) => Renderable (Path v) ShowBackend where+  render _ p = SR $ text (show p)
+ src/Diagrams/Combinators.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE TypeFamilies+           , FlexibleContexts+           , UndecidableInstances+  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.Combinators+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Higher-level tools for combining diagrams.+--+-----------------------------------------------------------------------------++module Diagrams.Combinators+       ( -- * Unary operations++         withBounds+       , phantom, strut++       , pad++         -- * Binary operations+       , beside, besideBounds+       , append++         -- * n-ary operations+       , appends+       , position, decorateTrail+       , cat, cat', CatOpts(..), CatMethod(..)++       ) where++import Graphics.Rendering.Diagrams++import Diagrams.Segment (Segment(..))+import Diagrams.Path+import Diagrams.Align+import Diagrams.Util++import Data.AdditiveGroup+import Data.AffineSpace ((.-.))+import Data.VectorSpace++import Data.Monoid+import Data.List++import Data.Default++------------------------------------------------------------+-- Working with bounds+------------------------------------------------------------++-- XXX this isn't quite right!  Need to think about this a bit more...+-- | 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 b d = d `atop` phantom b++-- | @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++-- | @pad s@ \"pads\" a diagram, expanding its bounding region by a+--   factor of @s@.  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 :: ( 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++-- | @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@.  Useful for+--   manually creating separation between two diagrams.+strut :: ( Backend b v, InnerSpace v+         , OrderedField (Scalar v)+         , Monoid m+         )+      => v -> AnnDiagram b v m+strut v = phantom $ getBounds (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.+--+--   XXX picture+beside :: (HasOrigin a, Boundable a, Monoid a) => V a -> a -> a -> a+beside v d1 d2+  = align v d1 <> align (negateV v) d2++-- 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...++-- | @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)++-- | 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)]++------------------------------------------------------------+-- Combining multiple objects+------------------------------------------------------------++-- | @appends x ys@ appends each of the objects in @ys@ to the object+--   @x@ in the corresponding direction.  Note that each object in+--   @ys@ is positioned beside @x@ /without/ reference to the other+--   objects in @ys@, so this is not the same as iterating @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++-- | 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, Qualifiable a, Monoid a) => [(Point (V a), a)] -> a+position = mconcat . zipWith (|>) [1::Integer ..] . map (uncurry moveTo)++-- | Combine a list of diagrams (or paths) by using them to+--   \"decorate\" a trail, placing the local origin of one object at+--   each successive vertex of the trail.  If the trail and list of+--   objects have different lengths, the extra tail of the longer one+--   is ignored.+decorateTrail :: (HasOrigin a, Qualifiable a, Monoid a) => Trail (V a) -> [a] -> a+decorateTrail t = position . zip (trailVertices origin t)++-- | Methods for concatenating diagrams.+data CatMethod = Cat     -- ^ Normal catenation: simply put diagrams+                         --   next to one another (possibly with a+                         --   certain distance in between each). The+                         --   distance between successive diagram+                         --   /boundaries/ 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+                         --   not be.  Indeed, depending on the amount+                         --   of separation, diagrams may overlap.++-- | Options for 'cat''.+data CatOpts v = CatOpts { catMethod       :: CatMethod+                             -- ^ Which 'CatMethod' should be used:+                             --   normal catenation (default), or+                             --   distribution?+                         , sep             :: Scalar v+                             -- ^ How much separation should be used+                             --   between successive diagrams+                             --   (default: 0)?  When @catMethod =+                             --   Cat@, this is the distance between+                             --   /boundaries/; when @catMethod =+                             --   Distrib@, this is the distance+                             --   between /origins/.+                         , catOptsvProxy__ :: Proxy v+                             -- ^ This field exists solely to aid type inference;+                             --   please ignore it.+                         }++-- The reason the proxy field is necessary is that without it,+-- altering the sep field could theoretically change the type of a+-- CatOpts record.  This causes problems when writing an expression+-- like @with { sep = 10 }@, because knowing the type of the whole+-- expression does not tell us anything about the type of @with@, and+-- therefore the @Num (Scalar v)@ constraint cannot be satisfied.+-- Adding the Proxy field constrains the type of @with@ in @with {sep+-- = 10}@ to be the same as the type of the whole expression.++instance Num (Scalar v) => Default (CatOpts v) where+  def = CatOpts { catMethod       = Cat+                , sep             = 0+                , catOptsvProxy__ = Proxy+                }++-- | @cat v@ positions a list of objects so that their local origins+--   lie along a line in the direction of @v@.  Successive objects+--   will have their bounding regions 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, Qualifiable a, Monoid 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+--     origins).  The default is catenation.+--+--   * The amount of separation between successive diagram+--     boundaries/origins (depending on the spacing method).  The+--     default is 0.+--+--   'CatOpts' is an instance of 'Default', so 'with' may be used for+--   the second argument, as in @cat' (1,2) with {sep = 2}@.+--+--   Note that @cat' v with {catMethod = Distrib} === mconcat@+--   (distributing with a separation of 0 is the same as+--   superimposing).+cat' :: (HasOrigin a, Boundable a, Qualifiable a, Monoid a)+     => V a -> CatOpts (V a) -> [a] -> a+cat' _ (CatOpts { catMethod = Cat }) []     = mempty+cat' _ (CatOpts { catMethod = Cat }) [d]    = (1::Integer) |> d+cat' v (CatOpts { catMethod = Cat, sep = s }) (d:ds) =+  foldl' (\d1 d2 ->+           d1 <> (moveOriginBy (origin .-. boundary v d1)+                  . moveOriginBy (withLength s (negateV v))+                  . align (negateV v)+                  $ d2)+         )+         ((1::Integer) |> d)+         (zipWith (|>) [2::Integer ..] ds)++cat' v (CatOpts { catMethod = Distrib, sep = s }) ds =+  decorateTrail (fromOffsets (repeat (withLength s v))) ds+  -- infinite trail, no problem for Haskell =D
+ src/Diagrams/Path.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE TypeFamilies+           , FlexibleInstances+           , FlexibleContexts+           , DeriveFunctor+           , GeneralizedNewtypeDeriving+           , UndecidableInstances+  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.Path+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- 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).+--+-----------------------------------------------------------------------------++module Diagrams.Path+       (+         -- * Constructing path-like things++         PathLike(..), fromOffsets, fromVertices++         -- * Trails++       , Trail(..)++         -- ** Destructing trails++       , trailOffsets, trailOffset+       , trailVertices++         -- * Paths++       , Path(..)++         -- ** Constructing paths from trails++       , pathFromTrail+       , pathFromTrailAt++         -- ** Destructing paths++       , pathVertices++       ) where++import Graphics.Rendering.Diagrams++import Diagrams.Segment+import Diagrams.Util++import Data.VectorSpace+import Data.AffineSpace++import Data.Monoid+import qualified Data.Foldable as F+import qualified Data.Set as S++import Control.Arrow ((***))++------------------------------------------------------------+--  PathLike class+------------------------------------------------------------++-- XXX merge close/open into fromSegments and make Diagrams an instance?++-- | Type class for path-like things, which must be monoids.+--   Instances include 'Trail's and 'Path's.+class (Monoid p, VectorSpace (V p)) => PathLike p where++  -- | Set the starting point of the path-like thing.  Some path-like+  --   things (e.g. 'Trail's) may ignore this operation.+  setStart   :: Point (V p) -> p -> p++  -- | Construct a path-like thing from a list of 'Segment's.+  fromSegments :: [Segment (V p)] -> p++  -- | \"Close\" a path-like thing, by implicitly connecting the+  --   endpoint(s) back to the starting point(s).+  close :: p -> p++  -- | \"Open\" a path-like thing.+  open  :: p -> p++-- | Construct a path-like thing of linear segments from a list of+--   offsets.+fromOffsets :: PathLike p => [V p] -> p+fromOffsets = fromSegments . map Linear++-- | Construct a path-like thing of linear segments from a list of+--   vertices, with the first vertex as the starting point.+fromVertices :: PathLike p => [Point (V p)] -> p+fromVertices []         = mempty+fromVertices vvs@(v:vs) = setStart v $ fromOffsets (zipWith (flip (.-.)) vvs vs)++------------------------------------------------------------+--  Trails  ------------------------------------------------+------------------------------------------------------------++-- | A /trail/ is a sequence of segments placed end-to-end.  Trails+--   are thus translationally invariant, and form a monoid under+--   concatenation.  Trails can also be /open/ (the default) or+--   /closed/ (the final point in a closed trail is implicitly+--   connected back to the starting point).+data Trail v = Trail { trailSegments :: [Segment v]+                     , isClosed      :: Bool+                     }+  deriving (Show, Functor, Eq, Ord)++type instance V (Trail v) = v++-- | 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)++-- | Trails are 'PathLike' things.  Note that since trails are+--   translationally invariant, 'setStart' has no effect.+--   'fromSegments' creates an open trail.+instance VectorSpace v => PathLike (Trail v) where+  setStart _ tr     = tr+  fromSegments segs = Trail segs False+  close tr          = tr { isClosed = True }+  open tr           = tr { isClosed = False }++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++  getBounds (Trail segs _) =+    foldr (\seg bds -> moveOriginTo (P . negateV . segOffset $ seg) bds <> getBounds seg)+          mempty+          segs++------------------------------------------------------------+--  Computing with trails  ---------------------------------+------------------------------------------------------------++-- | Extract the offsets of the segments of a trail.+trailOffsets :: Trail v -> [v]+trailOffsets (Trail segs _) = map segOffset segs++-- | Compute the offset from the start of a trail to the end.+trailOffset :: AdditiveGroup v => Trail v -> v+trailOffset = sumV . trailOffsets++-- | Extract the vertices of a trail, given a concrete location at+--   which to place the first vertex.+trailVertices :: AdditiveGroup v => Point v -> Trail v -> [Point v]+trailVertices p = scanl (.+^) p . trailOffsets++------------------------------------------------------------+--  Paths  -------------------------------------------------+------------------------------------------------------------++-- | A /path/ is a (possibly empty) collection of trails, with each+--   trail paired with an absolute starting point. Hence, paths+--   are /not/ translationally invariant, and form a monoid under+--   union\/superposition.+newtype Path v = Path { pathTrails :: S.Set (Trail v, Point v) }+  deriving (Show, Monoid, Eq, Ord)++type instance V (Path v) = v++instance (Ord v, VectorSpace v) => HasOrigin (Path v) where+  moveOriginTo p (Path s) = Path $ S.map (id *** moveOriginTo p) s++-- | 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+  setStart = moveTo++  fromSegments []   = Path $ S.empty+  fromSegments segs = Path $ S.singleton (fromSegments segs, origin)++  close (Path s) = Path $ S.map (close *** id) s+  open  (Path s) = Path $ S.map (open  *** id) s++-- See Note [Transforming paths]+instance (HasLinearMap v, Ord v) => Transformable (Path v) where+  transform t (Path s) = Path $ S.map (transform t *** transform t) s++{- ~~~~ Note [Transforming paths]++Careful!  It's tempting to just define++> transform = fmap . transform++but that doesn't take into account the fact that some+of the v's are inside Points and hence ought to be translated.+-}++instance (InnerSpace v, OrderedField (Scalar v)) => Boundable (Path v) where++  getBounds (Path trs) =  F.foldMap trailBounds trs+    where trailBounds (t, p) = moveOriginTo ((-1) *. p) (getBounds t)++------------------------------------------------------------+--  Constructing paths from trails  ------------------------+------------------------------------------------------------++-- | Convert a trail to a path beginning at the origin.+pathFromTrail :: AdditiveGroup v => Trail v -> Path v+pathFromTrail t = Path $ S.singleton (t, origin)++-- | Convert a trail to a path with a particular starting point.+pathFromTrailAt :: Trail v -> Point v -> Path v+pathFromTrailAt t p = Path $ S.singleton (t, p)++------------------------------------------------------------+--  Destructing paths  -------------------------------------+------------------------------------------------------------++-- | Extract the vertices of a path.+pathVertices :: (AdditiveGroup v, Ord v) => Path v -> S.Set [Point v]+pathVertices (Path trs) = S.map (\(tr, p) -> trailVertices p tr) trs
+ src/Diagrams/Prelude.hs view
@@ -0,0 +1,72 @@+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.Prelude+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- A module to re-export most of the functionality of the diagrams+-- core and standard library.+--+-----------------------------------------------------------------------------++module Diagrams.Prelude+       (+         -- * Core library+         -- | The core definitions of transformations, diagrams,+         --   backends, and so on.+         module Graphics.Rendering.Diagrams++         -- * Standard library+         -- | Attributes (color, line style, etc.) and styles.+       , module Diagrams.Attributes++         -- | General alignment of diagrams.+       , module Diagrams.Align++         -- | Combining multiple diagrams into one.+       , module Diagrams.Combinators++         -- | Linear and cubic bezier segments.+       , module Diagrams.Segment++         -- | Trails and paths.+       , module Diagrams.Path++         -- | A wide range of things (shapes, transformations,+         --   combinators) specific to creating two-dimensional+         --   diagrams.+       , module Diagrams.TwoD++         -- | 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+         -- | For computing with vectors.+       , module Data.VectorSpace+         -- | For computing with points and vectors.+       , module Data.AffineSpace++       ) where++import Graphics.Rendering.Diagrams++import Diagrams.Attributes+import Diagrams.Align+import Diagrams.Combinators+import Diagrams.Path+import Diagrams.Segment+import Diagrams.TwoD+import Diagrams.Util++import Data.Monoid+import Data.VectorSpace hiding (Sum(..))+import Data.AffineSpace++import Data.Colour.Names
+ src/Diagrams/Segment.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE TypeFamilies+           , FlexibleContexts+           , FlexibleInstances+           , DeriveFunctor+           , UndecidableInstances+  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.Segment+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Generic functionality for constructing and manipulating linear or+-- cubic Bezier segments.+--+-----------------------------------------------------------------------------++module Diagrams.Segment+       ( -- * Constructing segments++         Segment(..), straight, bezier3++         -- * Computing with segments+       , atParam, segOffset+       , splitAtParam, arcLength++       ) where++import Graphics.Rendering.Diagrams++import Diagrams.Solve++import Data.VectorSpace++import Control.Applicative (liftA2)++------------------------------------------------------------+--  Constructing segments  ---------------------------------+------------------------------------------------------------++-- | The atomic constituents of paths are /segments/, which are single+--   straight lines or cubic Bezier 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+                              --   three offsets from the starting+                              --   point to the first control point,+                              --   second control point, and ending+                              --   point, respectively.+  deriving (Show, Functor, Eq, Ord)++type instance V (Segment v) = v++instance HasLinearMap v => Transformable (Segment v) where+  transform = fmap . apply++-- | @'straight' v@ constructs a translationally invariant linear+--   segment with direction and length given by the vector @v@.+straight :: v -> Segment v+straight v = Linear v++-- Note, if we didn't have a Linear constructor we could also create+-- linear segments with @Cubic (v ^/ 3) (2 *^ (v ^/ 3)) v@.  Those+-- would not be precisely the same, however, since we can actually+-- observe how segments are parametrized.++-- | @bezier3 v1 v2 v3@ constructs a translationally invariant cubic+--   Bezier 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+bezier3 = Cubic++-- | 'atParam' yields a parametrized view of segments as continuous+--   functions @[0,1] -> v@, which give the offset from the start of+--   the segment for each value of the parameter between @0@ and @1@.+--   It is designed to be used infix, like @seg `atParam` 0.5@.+atParam :: (VectorSpace v, Num (Scalar v)) => Segment v -> Scalar v -> v+atParam (Linear x) t       = t *^ x+atParam (Cubic c1 c2 x2) t =     (3 * t'*t'*t ) *^ c1+                             ^+^ (3 * t'*t *t ) *^ c2+                             ^+^ (    t *t *t ) *^ x2+  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+--   same as the length of the curve itself; for that, see 'arcLength'.+segOffset :: Segment v -> v+segOffset (Linear v)    = v+segOffset (Cubic _ _ v) = v++------------------------------------------------------------+--  Computing segment bounds  ------------------------------+------------------------------------------------------------++{- 3 (1-t)^2 t c1 + 3 (1-t) t^2 c2 + t^3 x2++   Can we compute the projection of B(t) onto a given vector v?++   u.v = |u||v| cos th++   |proj_v u| = cos th * |u|+              = (u.v/|v|)++   so B_v(t) = (B(t).v/|v|)++   Then take the derivative of this wrt. t, get a quadratic, solve.++   B_v(t) = (1/|v|) *     -- note this does not affect max/min, can solve for t first+            3 (1-t)^2 t (c1.v) + 3 (1-t) t^2 (c2.v) + t^3 (x2.v)+          = t^3 ((3c1 - 3c2 + x2).v) + t^2 ((-6c1 + 3c2).v) + t (3c1.v)++   B_v'(t) = t^2 (3(3c1 - 3c2 + x2).v) + t (6(-2c1 + c2).v) + 3c1.v++   Set equal to zero, use quadratic formula.+-}++-- | 'splitAtParam' splits a segment @s@ into two new segments @(l,r)@+--   at the parameter @t@ where @l@ corresponds to the portion of+--   @s@ for parameter values from @0@ to @t@ and @r@ for @s@ from @t@ to @1@.+--   The following should hold for splitting:+--+-- > paramSplit s t u+-- >   | u < t     = atParam s u == atParam l (u / t)+-- >   | otherwise = atParam s u == atParam s t ^+^ atParam l ((u - t) / (1.0 - t))+-- >   where (l,r) = splitAtParam s t+--+--   That is to say, the parameterization scales linearly with splitting.+splitAtParam :: (VectorSpace v) => Segment v -> Scalar v -> (Segment v, Segment v)+splitAtParam (Linear x1) t = (left, right)+  where left  = Linear p+        right = Linear (x1 ^-^ p)+        p = lerp zeroV x1 t+splitAtParam (Cubic c1 c2 x2) t = (left, right)+  where left  = Cubic a b e+        right = Cubic (c ^-^ e) (d ^-^ e) (x2 ^-^ e)+        p = lerp c1    c2 t+        a = lerp zeroV c1 t+        b = lerp a     p  t+        d = lerp c2    x2 t+        c = lerp p     d  t+        e = lerp b     c  t++-- | 'arcLength' @s m@ approximates the arc length of the segment curve @s@ with+--   accuracy of at least plus or minus @m@.  For a 'Cubic' segment this is computed+--   by subdividing until the arc length of the path through the control points is+--   within @m@ of distance from start to end.+arcLength :: (InnerSpace v, Floating (Scalar v), Ord (Scalar v))+          => Segment v -> Scalar v -> Scalar v+arcLength (Linear x1) _ = magnitude x1+arcLength s@(Cubic c1 c2 x2) m+  | ub - lb < m = (ub + lb) / 2+  | otherwise   = arcLength l m + arcLength r m+ where (l,r) = splitAtParam s 0.5+       ub    = sum (map magnitude [c1, c2 ^-^ c1, x2 ^-^ c2])+       lb    = magnitude x2+++-- | The bounding function for a segment is based at the segment's+--   start.+instance (InnerSpace v, OrderedField (Scalar v)) => Boundable (Segment v) where++  getBounds (s@(Linear {})) = Bounds $ \v ->+    maximum . map (\t -> ((s `atParam` t) <.> v) / magnitudeSq v) $ [0,1]++  getBounds (s@(Cubic c1 c2 x2)) = Bounds $ \v ->+    maximum .+    map (\t -> ((s `atParam` t) <.> v) / magnitudeSq v) $+    [0,1] +++    filter (liftA2 (&&) (>0) (<1))+      (quadForm (3 * ((3 *^ c1 ^-^ 3 *^ c2 ^+^ x2) <.> v))+                (6 * (((-2) *^ c1 ^+^ c2) <.> v))+                ((3 *^ c1) <.> v))
+ src/Diagrams/Solve.hs view
@@ -0,0 +1,111 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.Solve+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Exact solving of low-degree (n <= 3) polynomials.+--+-----------------------------------------------------------------------------+module Diagrams.Solve+       ( quadForm+       , cubForm+       ) where++import Data.List (maximumBy)+import Data.Ord (comparing)++------------------------------------------------------------+-- Quadratic formula+------------------------------------------------------------++-- | The quadratic formula.+quadForm :: (Floating d, Ord d) => d -> d -> d -> [d]+quadForm a b c++    -- There are infinitely many solutions in this case,+    -- so arbitrarily return 0+  | a == 0 && b == 0 && c == 0 = [0]++    -- c = 0+  | a == 0 && b == 0 = []++    -- linear+  | a == 0    = [-c/b]++    -- no real solutions+  | d < 0     = []++    -- multiplicity 2 solution+  | d == 0    = [-b/(2*a)]++  | otherwise = [(-b + sqrt d)/(2*a), (-b - sqrt d)/(2*a)]+ where d = b*b - 4*a*c++quadForm_prop :: Double -> Double -> Double -> Bool+quadForm_prop a b c = all (aboutZero . eval) (quadForm a b c)+  where eval x = a*x*x + b*x + c+        aboutZero x = abs x < tolerance+        tolerance = 1e-10++------------------------------------------------------------+-- Cubic formula+------------------------------------------------------------++-- See http://en.wikipedia.org/wiki/Cubic_formula#General_formula_of_roots++-- | Solve the cubic equation ax^3 + bx^2 + cx + d = 0, returning a+--   list of all real roots.+cubForm :: (Floating d, Ord d) => d -> d -> d -> d -> [d]+cubForm a b c d+  | aboutZero a             = quadForm b c d++    -- three real roots, use trig method to avoid complex numbers+  | delta >  0              = map trig [0,1,2]++    -- one real root of multiplicity 3+  | delta == 0 && disc == 0 = [ -b/(3*a) ]++    -- two real roots, one of multiplicity 2+  | delta == 0 && disc /= 0 = [ (b*c - 9*a*d)/(2*disc)+                              , (9*a*a*d - 4*a*b*c + b*b*b)/(a * disc)+                              ]++    -- one real root (and two complex)+  | otherwise               = [-b/(3*a) - cc/(3*a) + disc/(3*a*cc)]++ where delta  = 18*a*b*c*d - 4*b*b*b*d + b*b*c*c - 4*a*c*c*c - 27*a*a*d*d+       disc   = 3*a*c - b*b+       qq     = sqrt(-27*a*a*delta)+       qq'    | aboutZero disc = maximumBy (comparing (abs . (+xx))) [qq, -qq]+              | otherwise = qq+       cc     = cubert (1/2*(qq' + xx))+       xx     = 2*b*b*b - 9*a*b*c + 27*a*a*d+       p      = disc/(3*a*a)+       q      = xx/(27*a*a*a)+       trig k = 2 * sqrt(-p/3) * cos(1/3*acos(3*q/(2*p)*sqrt(-3/p)) - k*2*pi/3)+                - b/(3*a)++       cubert x | x < 0     = -((-x)**(1/3))+                | otherwise = x**(1/3)++       aboutZero x = abs x < toler+       toler = 1e-10++cubForm_prop :: Double -> Double -> Double -> Double -> Bool+cubForm_prop a b c d = all (aboutZero . eval) (cubForm a b c d)+  where eval x = a*x*x*x + b*x*x + c*x + d+        aboutZero x = abs x < tolerance+        tolerance = 1e-5+           -- Basically, however large you set the tolerance it seems+           -- that quickcheck can always come up with examples where+           -- the returned solutions evaluate to something near zero+           -- but larger than the tolerance (but it takes it more+           -- tries the larger you set the tolerance). Wonder if this+           -- is an inherent limitation or (more likely) a problem+           -- with numerical stability.  If this turns out to be an+           -- issue in practice we could, say, use the solutions+           -- generated here as very good guesses to a numerical+           -- solver which can give us a more precise answer?
+ src/Diagrams/TwoD.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.TwoD+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- This module defines the two-dimensional vector space R^2,+-- two-dimensional transformations, and various predefined+-- two-dimensional shapes.  This module re-exports useful+-- functionality from a group of more specific modules:+--+--   * "Diagrams.TwoD.Types" defines basic types for two-dimensional+--     diagrams.+--+--   * "Diagrams.TwoD.Align" defines alignment combinators specialized+--     to two dimensions (see "Diagrams.Align" for more general+--     alignment).+--+--   * "Diagrams.TwoD.Combinators" defines ways of combining diagrams+--     specialized to two dimensions (see also "Diagrams.Combinators"+--     for more general combining).+--+--   * "Diagrams.TwoD.Transform" defines R^2-specific transformations+--     such as rotation by an angle, and scaling, translation, and+--     reflection in the X and Y directions.+--+--   * "Diagrams.TwoD.Ellipse" defines ellipses.+--+--   * "Diagrams.TwoD.Arc" defines circular arcs.+--+--   * "Diagrams.TwoD.Path" exports various operations on+--     two-dimensional paths when viewed as regions of the plane.+--+--   * "Diagrams.TwoD.Shapes" defines other two-dimensional shapes,+--     e.g. various polygons.+--+--   * "Diagrams.TwoD.Util" defines some two-dimensional utilities,+--     such as unit vectors and functions for computing the size and+--     extent of diagrams in R^2.+--+--   * "Diagrams.TwoD.Model" defines some aids for visualizing+--     diagrams' internal model (local origins, bounding regions,+--     etc.)+--+-----------------------------------------------------------------------------+module Diagrams.TwoD+       ( -- * R^2+         R2+       , P2+       , Angle+       , unitX, unitY++         -- * Paths+       , stroke, strokeT++         -- * Shapes+         -- ** Rules+       , hrule, vrule++         -- ** Circle-ish things+       , circle+       , ellipse+       , arc++         -- ** General polygons+       , polygon, polygonPath, polygonVertices+       , PolygonOpts(..), PolygonOrientation(..)++         -- ** Special polygons+       , square+       , starPolygon+       , eqTriangle++         -- * Transformations+         -- ** Rotation+       , rotation, rotate+       , rotationBy, rotateBy+         -- ** Scaling+       , scalingX, scaleX+       , scalingY, scaleY+       , scaling, scale+         -- ** Translation+       , translationX, translateX+       , translationY, translateY+       , translation, translate+         -- ** Reflection+       , reflectionX, reflectX+       , reflectionY, reflectY++         -- * Combinators+       , strutX, strutY++       , (===), (|||)+       , hcat, hcat'+       , vcat, vcat'++         -- * Alignment+       , alignL, alignR, alignT, alignB, alignTL, alignTR, alignBL, alignBR+       , alignX, alignY+       , centerX, centerY, centerXY++         -- * Utilities+       , width, height, size2D+       , extentX, extentY, center2D++         -- * Visual aids for understanding the internal model+       , showOrigin+       ) where++import Diagrams.TwoD.Types+import Diagrams.TwoD.Path+import Diagrams.TwoD.Ellipse+import Diagrams.TwoD.Arc+import Diagrams.TwoD.Shapes+import Diagrams.TwoD.Transform+import Diagrams.TwoD.Align+import Diagrams.TwoD.Combinators+import Diagrams.TwoD.Util+import Diagrams.TwoD.Model
+ src/Diagrams/TwoD/Align.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE FlexibleContexts+           , TypeFamilies+  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.TwoD.Align+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Alignment combinators specialized for two dimensions.  See+-- "Diagrams.Align" for more general alignment combinators.+--+-- The basic idea is that alignment is achieved by moving diagrams'+-- local origins relative to their 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+-- "Diagrams.TwoD.Combinators").+--+-----------------------------------------------------------------------------++module Diagrams.TwoD.Align+    ( -- * Absolute alignment+      alignL, alignR, alignT, alignB+    , alignTL, alignTR, alignBL, alignBR++      -- * Relative alignment+    , alignX, alignY++      -- * Centering+    , centerX, centerY, centerXY++    ) where++import Graphics.Rendering.Diagrams++import Diagrams.TwoD.Types+import Diagrams.TwoD.Util+import Diagrams.Align++import Data.VectorSpace++-- | Align along the left edge, i.e. translate the diagram in a+--   horizontal direction so that the local origin is on the left edge+--   of the bounding region.+alignL :: (HasOrigin a, Boundable 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 = align unitX++-- | Align along the top edge.+alignT :: (HasOrigin a, Boundable 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 = align (negateV unitY)++alignTL, alignTR, alignBL, alignBR :: (HasOrigin a, Boundable a, V a ~ R2) => a -> a+alignTL = alignT . alignL+alignTR = alignT . alignR+alignBL = alignB . alignL+alignBR = alignB . alignR++-- | @alignX@ moves the local origin horizontally as follows:+--+--   * @alignX (-1)@ moves the local origin to the left edge of the bounding region;+--+--   * @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) => Rational -> 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) => Rational -> a -> a+alignY = alignBy unitY++-- | Center the local origin along the X-axis.+centerX  :: (HasOrigin a, Boundable 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  = alignBy unitY 0++-- | Center along both the X- and Y-axes.+centerXY :: (HasOrigin a, Boundable a, V a ~ R2) => a -> a+centerXY = centerX . centerY
+ src/Diagrams/TwoD/Arc.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.TwoD.Arc+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Two-dimensional arcs, approximated by cubic bezier curves.+--+-----------------------------------------------------------------------------++module Diagrams.TwoD.Arc+    ( arc, arcT+    , bezierFromSweep+    ) where++import Graphics.Rendering.Diagrams++import Diagrams.TwoD.Types+import Diagrams.TwoD.Transform++import Diagrams.Path+import Diagrams.Segment++import Data.VectorSpace((^-^))++-- For details of this approximation see:+--   http://www.tinaja.com/glib/bezcirc2.pdf++-- | @bezierFromSweepQ1 s@ constructs a 'Cubic' segment that starts in+--   the positive y direction and sweeps counterclockwise through @s@+--   radians.  The approximation is only valid for angles in the first+--   quadrant.+bezierFromSweepQ1 :: Angle -> 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)++-- | @bezierFromSweep s@ constructs a series of 'Cubic' segments that+--   start in the positive y direction and sweep counter clockwise+--   through @s@ radians.  If @s@ is negative, it will start in the+--   negative y direction and sweep clockwise.  When @s@ is less than+--   0.0001 the empty list results.  If the sweep is greater than two pi+--   then it is truncated to two pi.+bezierFromSweep :: Angle -> [Segment R2]+bezierFromSweep s+  | s > 2 * pi = bezierFromSweep (2*pi)+  | s < 0      = fmap reflectY . bezierFromSweep $ (-s)+  | s < pi/2   = [bezierFromSweepQ1 s]+  | s < 0.0001 = []+  | otherwise  = bezierFromSweepQ1 (pi/2)+          : map (rotate (pi/2)) (bezierFromSweep (max (s-pi/2) 0))++{-+~~~~ Note [segment spacing]++There are a few obvious options for segment spacing:+   A. Evenly space segments each with sweep less than or equal+      to half pi.  This has the benefit of a better approximation+      (at least I think it is better).+   B. Use as much of the sweep in half pi sized segments and one for+      the remainder.  This potentially gives more opportunities for+      consistency (though not as much as option C) as the error in+      approximation would more often match the error from another arc+      in the diagram.+   C. Like option B but fixing the orientation and having a remnant at+      the beginning and the end.++Option B is implemented and this note is for posterity if anyone comes+across a situation with large enough arcs that they can actually see+the approximation error.+-}++-- | A version of 'arc' that produces a 'Trail' instead of a 'Path'.+arcT :: Angle -> Angle -> Trail R2+arcT start end = Trail bs (sweep >= pi*2)+  where sweep = end - start+        bs    = map (rotate start) . bezierFromSweep $ sweep++-- | Given a start angle @s@ and an end angle @e@ (both in radians),+--   @'arc' s e@ is the path of a radius one arc counterclockwise+--   between the two angles.+arc :: Angle -> Angle -> Path R2+arc start end = pathFromTrailAt (arcT start end) (rotate start $ P (1,0))
+ src/Diagrams/TwoD/Combinators.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE FlexibleContexts+           , TypeFamilies+  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.TwoD.Combinators+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Diagram combinators specialized to two dimensions. For more general+-- combinators, see "Diagrams.Combinators".+--+-----------------------------------------------------------------------------++module Diagrams.TwoD.Combinators+    (+      -- * Binary combinators++      (===), (|||)++      -- * n-ary combinators+    , hcat, hcat'+    , vcat, vcat'++      -- * Struts+    , strutX, strutY+    ) where++import Graphics.Rendering.Diagrams++import Diagrams.TwoD.Types+import Diagrams.TwoD.Util+import Diagrams.Combinators++import Data.VectorSpace++import Data.Monoid+import Data.Default++infixl 6 ===+infixl 6 |||++-- | Place two diagrams (or other boundable objects) vertically+--   adjacent to one another, with the first diagram above the second.+--   Since Haskell ignores whitespace in expressions, one can thus write+--+--   >    c+--   >   ===+--   >    d+--+--   to place @c@ above @d@.+(===) :: (HasOrigin a, Boundable a, V a ~ R2, Monoid a) => a -> a -> a+(===) = beside (negateV unitY)++-- | Place two diagrams (or other boundable 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+(|||) = beside unitX++-- | Lay out a list of boundable 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.+--+--   * For more control over the spacing, see 'hcat''.+--+--   * To align the diagrams vertically (or otherwise), use alignment+--   combinators (such as 'alignTop' or 'alignBottom') from+--   "Diagrams.TwoD.Align" before applying 'hcat'.+--+--   * For non-axis-aligned layout, see 'cat'.+hcat :: (HasOrigin a, Boundable a, Qualifiable a, V a ~ R2, Monoid a) => [a] -> a+hcat = hcat' def++-- | A variant of 'hcat' taking an extra 'CatOpts' record to control+--   the spacing.  See the 'cat'' documentation for a description of+--   the possibilities.+hcat' :: (HasOrigin a, Boundable a, Qualifiable a, V a ~ R2, Monoid a) => 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.+--+--   * For more control over the spacing, see 'vcat''.+--+--   * To align the diagrams horizontally (or otherwise), use alignment+--   combinators (such as 'alignLeft' or 'alignRight') from+--   "Diagrams.TwoD.Align" before applying 'vcat'.+--+--   * For non-axis-aligned layout, see 'cat'.+vcat :: (HasOrigin a, Boundable a, Qualifiable a, V a ~ R2, Monoid a) => [a] -> a+vcat = vcat' def++-- | A variant of 'vcat' taking an extra 'CatOpts' record to control+--   the spacing.  See the 'cat'' documentation for a description of the+--   possibilities.+vcat' :: (HasOrigin a, Boundable a, Qualifiable a, V a ~ R2, Monoid a) => CatOpts R2 -> [a] -> a+vcat' = cat' (negateV unitY)++-- | @strutX d@ is an empty diagram with width @d@ and height 0.+strutX :: (Backend b R2, Monoid m) => Double -> AnnDiagram b R2 m+strutX d = strut (d,0)++-- | @strutY d@ is an empty diagram with height @d@ and width 0.+strutY :: (Backend b R2, Monoid m) => Double -> AnnDiagram b R2 m+strutY d = strut (0,d)
+ src/Diagrams/TwoD/Ellipse.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE FlexibleContexts+           , TypeSynonymInstances+           , MultiParamTypeClasses+           , TypeFamilies+  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.TwoD.Ellipse+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Two-dimensional ellipses (and, as a special case, circles).+--+-----------------------------------------------------------------------------++module Diagrams.TwoD.Ellipse+    (+      -- * Ellipse and circle diagrams+      circle+    , ellipse++      -- * Mathematical ellipses+      -- ** Representation+    , Ellipse(..)++      -- ** Extracting attributes+    , ellipseCenter+    , ellipseAngle+    , ellipseAxes+    , ellipseScale++    , ellipseCoeffs++    ) where++import Graphics.Rendering.Diagrams+import Graphics.Rendering.Diagrams.Util++import Diagrams.TwoD.Types+import Diagrams.TwoD.Transform++import Data.Monoid (Any(..), mempty)++import Data.VectorSpace (magnitudeSq, magnitude, (^-^))++-- | An ellipse is represented by an affine transformation acting on+--   the unit circle.+data Ellipse = Ellipse (Transformation R2)++type instance V Ellipse = R2++instance Transformable Ellipse where+  transform t (Ellipse e) = Ellipse (t <> e)++-- | A circle of radius 1.+circle :: (Backend b R2, Renderable Ellipse b) => Diagram b R2+circle = mkAD (Prim $ Ellipse mempty)+              (Bounds circleBounds)+              (fromNames [ ("C", P ( 0, 0))+                         , ("E", P ( 1, 0))+                         , ("N", P ( 0, 1))+                         , ("W", P (-1, 0))+                         , ("S", P ( 0,-1)) ])+              (Query circleQuery)+  where circleBounds (x,y) = 1 / sqrt(x*x + y*y)+        circleQuery (P (x,y)) = Any $ x*x + y*y <= 1++-- | @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 e+    | e >= 0 && e < 1  = scaleX (sqrt (1 - e*e)) circle+    | otherwise        = error "Eccentricity of ellipse must be >= 0 and < 1."++-- | 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.  The result will+--   be in the range [0, pi).+ellipseAngle :: Ellipse -> Angle+ellipseAngle ell+  | y < 0     = pi + atan2 y x+  | otherwise = 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
+ src/Diagrams/TwoD/Model.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE FlexibleContexts+  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.TwoD.Model+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Tools for visualizing diagrams' internal model: local origins,+-- bounding regions, etc.+--+-----------------------------------------------------------------------------+module Diagrams.TwoD.Model+       ( -- * Showing the local origin+         showOrigin+       ) where++import Graphics.Rendering.Diagrams+-- import Graphics.Rendering.Diagrams.UDTree+import Diagrams.TwoD.Types+import Diagrams.TwoD.Ellipse+import Diagrams.TwoD.Util+import Diagrams.Attributes+import Diagrams.Util++import Data.Monoid++import Data.Colour.Names++------------------------------------------------------------+-- 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 # fc red+                       # lw 0+                       # scale (max (w/50) (h/50))+                       # fmap (const mempty)+        (w,h) = size2D d++-- data OriginOpts b m = OriginOpts { oDia   :: AnnDiagram b R2 m+--                                  , oScale :: Double+--                                  }++-- showOrigin' (OriginOpts o s) d = o' <> d+--   where o' = o # scale (max (w * s) (h * s))+--         (w,h) = size2D d++++-- XXX finish:++--   Draw the separating lines between diagrams composed with 'beside'+--   (or any combinators implemented in terms of 'beside', like '(|||)'+--   or '(===)').++-- showSep :: AnnDiagram b R2 m -> AnnDiagram b R2 m+-- showSep d = s <> d+--   where ... = case d of+--                 AnnDiagram (Branch u ds children) -> ...
+ src/Diagrams/TwoD/Path.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE FlexibleContexts+  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.TwoD.Path+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Paths in two dimensions are special since we may stroke them to+-- create a 2D diagram, and (eventually) perform operations such as+-- intersection and union.+--+-----------------------------------------------------------------------------++module Diagrams.TwoD.Path+       ( -- * Constructing path-based diagrams++         stroke, strokeT++       ) where++import Graphics.Rendering.Diagrams++import Diagrams.Segment+import Diagrams.Path+import Diagrams.TwoD.Types+import Diagrams.Solve++import Data.AdditiveGroup+import Data.VectorSpace+import Data.AffineSpace++import Data.Monoid+import Control.Applicative (liftA2)+import qualified Data.Set as S+import qualified Data.Foldable as F++------------------------------------------------------------+--  Constructing path-based diagrams  ----------------------+------------------------------------------------------------++-- | Convert a path into a diagram.  The resulting diagram has the+--   names 0, 1, ... assigned to each of the path's vertices.+--+--   Note that a bug in GHC 7.0.1 causes a context stack overflow when+--   inferring the type of @stroke@.  The solution is to give a type+--   signature to expressions involving @stroke@, or (recommended)+--   upgrade GHC (the bug is fixed in 7.0.2 onwards).+stroke :: (Renderable (Path R2) b)+       => Path R2 -> Diagram b R2+stroke p = mkAD (Prim p)+                (getBounds p)+                mempty+                {-  XXX what to do here?+                    fromNames $ zip ([0..] :: [Int])+                                    (pathVertices p)  -- XXX names for Bezier+                                                      --   control points too?+                -}+                (Query $ Any . flip isInsideWinding p)++-- | A composition of 'stroke' and 'pathFromTrail' for conveniently+--   converting a trail directly into a diagram.+--+--   Note that a bug in GHC 7.0.1 causes a context stack overflow when+--   inferring the type of 'stroke' and hence of @strokeT@ as well.+--   The solution is to give a type signature to expressions involving+--   @strokeT@, or (recommended) upgrade GHC (the bug is fixed in 7.0.2+--   onwards).+strokeT :: (Renderable (Path R2) b)+        => Trail R2 -> Diagram b R2+strokeT = stroke . pathFromTrail++------------------------------------------------------------+--  Inside/outside testing+------------------------------------------------------------++cross :: R2 -> R2 -> Double+cross (x,y) (x',y') = x * y' - y * x'++isInsideWinding :: P2 -> Path R2 -> Bool+isInsideWinding p = (/= 0) . crossings p++isInsideEvenOdd :: P2 -> Path R2 -> Bool+isInsideEvenOdd p = odd . crossings p++data FixedSegment v = FLinear (Point v) (Point v)+                    | FCubic (Point v) (Point v) (Point v) (Point v)+  deriving Show++mkFixedSeg :: AdditiveGroup v => Point v -> Segment v -> FixedSegment v+mkFixedSeg p (Linear v)       = FLinear p (p .+^ v)+mkFixedSeg p (Cubic c1 c2 x2) = FCubic p (p .+^ c1) (p .+^ c2) (p .+^ x2)++fAtParam :: VectorSpace v => FixedSegment v -> Scalar v -> Point v+fAtParam (FLinear p1 p2) t = alerp p1 p2 t+fAtParam (FCubic x1 c1 c2 x2) t = p3+  where p11 = alerp x1 c1 t+        p12 = alerp c1 c2 t+        p13 = alerp c2 x2 t++        p21 = alerp p11 p12 t+        p22 = alerp p12 p13 t++        p3  = alerp p21 p22 t++-- | Compute the sum of /signed/ crossings of a path as we travel in the+--   positive x direction from a given point.+crossings :: P2 -> Path R2 -> Int+crossings p = F.sum . S.map (trailCrossings p) . pathTrails++-- | Compute the sum of signed crossings of a trail starting from the+--   given point in the positive x direction.+trailCrossings :: P2 -> (Trail R2, P2) -> Int++  -- open trails have no inside or outside, so don't contribute crossings+trailCrossings _ (t, _) | not (isClosed t) = 0++trailCrossings p@(P (x,y)) (tr, start)+  = sum . map test+  $ zipWith mkFixedSeg (trailVertices start tr)+                       (trailSegments tr ++ [Linear . negateV . trailOffset $ tr])+  where+    test (FLinear a@(P (_,ay)) b@(P (_,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))) =+        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+                      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 < pi && t < 1)  -> 1+                               | (-pi < ang && ang < 0 && t > 0) -> -1+                               | otherwise                       -> 0++    isLeft a b = cross (b .-. a) (p .-. a)+
+ src/Diagrams/TwoD/Shapes.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.TwoD.Shapes+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Various two-dimensional shapes.+--+-----------------------------------------------------------------------------++module Diagrams.TwoD.Shapes+       (+         -- * Miscellaneous+         hrule, vrule++         -- * General polygons+       , polygon, polygonPath, polygonVertices+       , PolygonOpts(..), PolygonOrientation(..)++         -- * Special polygons+       , square+       , starPolygon++       , eqTriangle+       ) where++import Graphics.Rendering.Diagrams++import Diagrams.Path+import Diagrams.TwoD.Path+import Diagrams.TwoD.Types+import Diagrams.TwoD.Transform+import Diagrams.TwoD.Align++import Diagrams.Util++import Data.Default++-- | Create a centered horizontal line of the given length.+hrule :: (Backend b R2, Renderable (Path R2) b) => Double -> Diagram b R2+hrule d = centerX . stroke $ fromOffsets [(d,0)]++-- | Create a centered vertical line of the given length.+vrule :: (Backend b R2, Renderable (Path R2) b) => Double -> Diagram b R2+vrule d = centerY . stroke $ fromOffsets [(0,d)]++-- | Determine how a polygon should be oriented.+data PolygonOrientation = NoOrient  -- ^ No special orientation; one+                                    --   vertex will be at (1,0).+                                    --   This is the default.+                        | OrientToX -- ^ Orient so the botommost edge+                                    --   is parallel to the x-axis.+                        | OrientToY -- ^ Orient so the leftmost edge+                                    --   is parallel to the y-axis.+  deriving (Eq, Ord, Show, Read)++data PolygonOpts = PolygonOpts {+    sides       :: Int    -- ^ Number of sides; the default is 5.+  , edgeSkip    :: Int    -- ^ Create star polygons by setting the+                          --   edge skip to some number other than 1+                          --   (the default).  With an edge skip of n,+                          --   edges will connect every nth vertex.+  , orientation :: PolygonOrientation+                          -- ^ Determine how the polygon should be+                          --   oriented.+  }+  deriving (Eq, Ord, Show, Read)++instance Default PolygonOpts where+  def = PolygonOpts { sides = 5, edgeSkip = 1, orientation = NoOrient }++-- | Create a regular polygon from the given options.+polygon :: (Backend b R2, Renderable (Path R2) b) => PolygonOpts -> Diagram b R2+polygon = stroke . polygonPath++-- | Create a closed regular polygonal path from the given options.+polygonPath :: (PathLike p, V p ~ R2) => PolygonOpts -> p+polygonPath = close . fromVertices . polygonVertices++-- | Generate the vertices of a regular polygon from the given+--   options.+polygonVertices :: PolygonOpts -> [P2]+polygonVertices opts = orient . take n . iterate (rotate angle) $ start+  where start  = translateX 1 origin+        angle  = (fromIntegral $ edgeSkip opts) * 2*pi / fromIntegral n+        n      = sides opts+        orient  | orientation opts == OrientToX = orientX+                | orientation opts == OrientToY = orientY+                | otherwise                     = id+        orientX | odd n          = rotateBy (1/4)+                | n `mod` 4 == 0 = rotate (angle/2)+                | otherwise      = id+        orientY | even n    = rotate (angle/2)+                | otherwise = id++-- | A sqaure with its center at the origin and sides of length 1,+--   oriented parallel to the axes.+square ::  (Backend b R2, Renderable (Path R2) b) => Diagram b R2+square = scale (1/sqrt 2) $ polygon def { sides = 4, orientation = OrientToX }++-- | @starPolygon p q@ creates a star polygon, where @p@ indicates the+--   number of vertices, and an edge connects every @q@th vertex.+starPolygon :: (Backend b R2, Renderable (Path R2) b) => Int -> Int -> Diagram b R2+starPolygon p q = polygon def { sides = p, edgeSkip = q }++-- | An equilateral triangle, with radius 1 and base parallel to the+--   x-axis.+eqTriangle :: (Backend b R2, Renderable (Path R2) b) => Diagram b R2+eqTriangle = polygon with {sides = 3, orientation = OrientToX}++{-+pentagon :: (Backend b R2, Renderable (Path R2) b) => Diagram b R2+pentagon = writeMe "pentagon"++hexagon :: (Backend b R2, Renderable (Path R2) b) => Diagram b R2+hexagon = writeMe "hexagon"++septagon :: (Backend b R2, Renderable (Path R2) b) => Diagram b R2+septagon = writeMe "septagon"++octagon :: (Backend b R2, Renderable (Path R2) b) => Diagram b R2+octagon = writeMe "octagon"++nonagon :: (Backend b R2, Renderable (Path R2) b) => Diagram b R2+nonagon = writeMe "nonagon"++decagon :: (Backend b R2, Renderable (Path R2) b) => Diagram b R2+decagon = writeMe "decagon"++-- | Construct a triangle from three side lengths, if possible.  The+--   longest side will be parallel to the x-axis.+triangleFromSides :: (Backend b R2, Renderable (Path R2) b)+                  => Double -> Double -> Double -> Maybe (Diagram b R2)+triangleFromSides = writeMe "triangleFromSides"+-}
+ src/Diagrams/TwoD/Transform.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE FlexibleContexts+           , TypeFamilies+  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.TwoD.Transform+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Transformations specific to two dimensions, with a few generic+-- transformations (uniform scaling, translation) also re-exported for+-- convenience.+--+-----------------------------------------------------------------------------++module Diagrams.TwoD.Transform+       (+         -- * Rotation+         rotation, rotate+       , rotationBy, rotateBy++         -- * Scaling+       , scalingX, scaleX+       , scalingY, scaleY+       , scaling, scale++         -- * Translation+       , translationX, translateX+       , translationY, translateY+       , translation, translate++         -- * Reflection+       , reflectionX, reflectX+       , reflectionY, reflectY+       ) where++import Graphics.Rendering.Diagrams++import Diagrams.TwoD.Types++import Control.Arrow (first, second)++-- | Create a transformation which performs a rotation by the given+--   angle in radians.+rotation :: Angle -> Transformation R2+rotation theta = fromLinear r (linv r)+  where+    rot th (x,y) = (cos th * x - sin th * y, sin th * x + cos th * y)+    r = rot theta <-> rot (-theta)++-- | Rotate by the given angle in radians.+rotate :: (Transformable t, V t ~ R2) => Angle -> t -> t+rotate = transform . rotation++-- | Create a transformation which performs a rotation by the given+--   fraction of a circle.  For example, @rotationBy (1/4)@ rotates by+--   one quarter of a circle (i.e. 90 degrees, i.e. pi/2 radians).+rotationBy :: Double -> Transformation R2+rotationBy = rotation . (*(2*pi))++-- | Rotate by the given fraction of a circle.+rotateBy :: (Transformable t, V t ~ R2) => Angle -> t -> t+rotateBy = transform . rotationBy++-- | Construct a transformation which scales by the given factor in+--   the x (horizontal) direction.+scalingX :: Double -> Transformation R2+scalingX c = fromLinear s s+  where s = first (*c) <-> first (/c)++-- | Scale a diagram by the given factor in the x (horizontal)+--   direction.  To scale uniformly, use+--   'Graphics.Rendering.Diagrams.Transform.scale'.+scaleX :: (Transformable t, V t ~ R2) => Double -> t -> t+scaleX = transform . scalingX++-- | Construct a transformation which scales by the given factor in+--   the y (vertical) direction.+scalingY :: Double -> Transformation R2+scalingY c = fromLinear s s+  where s = second (*c) <-> second (/c)++-- | Scale a diagram by the given factor in the y (vertical)+--   direction.  To scale uniformly, use+--   'Graphics.Rendering.Diagrams.Transform.scale'.+scaleY :: (Transformable t, V t ~ R2) => Double -> t -> t+scaleY = transform . scalingY++-- | Construct a transformation which translates by the given distance+--   in the x (horizontal) direction.+translationX :: Double -> Transformation R2+translationX x = translation (x,0)++-- | Translate a diagram by the given distance in the x (horizontal)+--   direction.+translateX :: (Transformable t, V t ~ R2) => Double -> t -> t+translateX = transform . translationX++-- | Construct a transformation which translates by the given distance+--   in the y (vertical) direction.+translationY :: Double -> Transformation R2+translationY y = translation (0,y)++-- | Translate a diagram by the given distance in the y (vertical)+--   direction.+translateY :: (Transformable t, V t ~ R2) => Double -> t -> t+translateY = transform . translationY++-- | Construct a transformation which flips a diagram from left to+--   right, i.e. sends the point (x,y) to (-x,y).+reflectionX :: Transformation R2+reflectionX = scalingX (-1)++-- | Flip a diagram from left to right, i.e. send the point (x,y) to+--   (-x,y).+reflectX :: (Transformable t, V t ~ R2) => t -> t+reflectX = transform reflectionX++-- | Construct a transformation which flips a diagram from top to+--   bottom, i.e. sends the point (x,y) to (x,-y).+reflectionY :: Transformation R2+reflectionY = scalingY (-1)++-- | Flip a diagram from top to bottom, i.e. send the point (x,y) to+--   (x,-y).+reflectY :: (Transformable t, V t ~ R2) => t -> t+reflectY = transform reflectionY++-- XXX todo: add general reflection/reflect operators which reflect+-- around an arbitrary axis (taking a vector as an argument).
+ src/Diagrams/TwoD/Types.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TypeFamilies+           , TypeSynonymInstances+  #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.TwoD.Types+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Basic types for two-dimensional Cartesian space.+--+-----------------------------------------------------------------------------++module Diagrams.TwoD.Types+       ( R2+       , P2+       , Angle+       ) where++import Graphics.Rendering.Diagrams++-- | The two-dimensional Euclidean vector space R^2.+type R2 = (Double, Double)++type instance V R2 = R2++-- | Points in R^2.+type P2 = Point R2++instance Transformable R2 where+  transform = apply++-- | Type synonym used to represent angles in radians.+type Angle = Double
+ src/Diagrams/TwoD/Util.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleContexts+  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.TwoD.Util+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Utility functions for diagrams in two-dimensional Cartesian space.+--+-----------------------------------------------------------------------------+module Diagrams.TwoD.Util+       ( -- * General two-dimensional utilities+         unitX, unitY++         -- * Size and extent of diagrams in R2+       , width, height, size2D+       , extentX, extentY, center2D+       ) where++import Graphics.Rendering.Diagrams+import Diagrams.TwoD.Types++import Control.Arrow ((***), (&&&))++-- | Compute the width of a diagram.+width :: AnnDiagram b R2 m -> Double+width = negate . uncurry (-) . extentX++-- | Compute the height of a diagram.+height :: AnnDiagram b R2 m -> Double+height = negate . uncurry (-) . extentY++-- | Compute the width and height of a diagram.+size2D :: AnnDiagram b R2 m -> (Double, Double)+size2D = width &&& height++-- | Compute the absolute x-coordinate range of a diagram in R2, in+--   the form (lo,hi).+extentX :: AnnDiagram b R2 a -> (Double, Double)+extentX d = (-f (-1,0), f (1,0))+  where f = appBounds $ getBounds d++-- | Compute the absolute y-coordinate range of a diagram in R2, in+--   the form (lo,hi).+extentY :: AnnDiagram b R2 a -> (Double, Double)+extentY d = (-f (0,-1), f (0,1))+  where f = appBounds $ getBounds d++-- | Compute the point at the center (in the x- and y-directions) of a+--   diagram.+center2D :: AnnDiagram b R2 a -> P2+center2D = P . (mid *** mid) . (extentX &&& extentY)+  where mid = (/2) . uncurry (+)++-- | A unit vector in the positive X direction.+unitX :: R2+unitX = (1,0)++-- | A unit vector in the positive Y direction.+unitY :: R2+unitY = (0,1)
+ src/Diagrams/Util.hs view
@@ -0,0 +1,94 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.Util+-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Some miscellaneous utilities provided by the diagrams-lib package.+--+-----------------------------------------------------------------------------++module Diagrams.Util+       ( -- * Utilities for users++         with+       , (<>)+       , (#)++         -- * Internal utilities+       , Proxy(..)++       ) where++import Data.Monoid+import Data.Default++-- | Several functions exported by the diagrams library take a number+--   of arguments giving the user control to \"tweak\" various aspects+--   of their behavior.  Rather than give such functions a long list+--   of arguments, and to make it possible for the user to selectively+--   override only certain arguments and use default values for+--   others, such sets of arguments are collected into a record with+--   named fields (see 'PolygonOpts' in "Diagrams.TwoD.Shapes" for an+--   example).  Such record types are made instances of the 'Default'+--   class, which provides a single record structure ('def')+--   collecting the \"default\" arguments to the function.  @with@ is+--   a synonym for 'def', which provides nice-looking syntax for+--   simulating optional, named arguments in Haskell.  For example,+--+--   > polygon with {sides = 7, edgeSkip = 2}+--+--   calls the 'polygon' function with a single argument (note that+--   record update binds more tightly than function application!),+--   namely, 'with' (the record of default arguments) where the+--   @sides@ and @edgeSkip@ fields have been updated.+with :: Default d => d+with = def++-- | 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 <>++infixl 8 #++-- | Postfix function application, for conveniently applying+--   attributes.  Unlike @($)@, @(#)@ has a high precedence (8), so @d+--   \# foo \# bar@ can be combined with other things using operators+--   like @(|||)@ or @(\<\>)@ without needing parentheses.+(#) :: a -> (a -> b) -> b+(#) = flip ($)++-- | A value of @Proxy a@ carries no information; it's used only to+--   fix the type @a@.+data Proxy a = Proxy