diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,35 @@ +Copyright 2011 diagrams-lib team: + + Kanchalai Suveepattananont + Scott Walck + Ryan Yates + Brent Yorgey + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Brent Yorgey nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal new file mode 100644 --- /dev/null +++ b/diagrams-lib.cabal @@ -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 diff --git a/src/Diagrams/Align.hs b/src/Diagrams/Align.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Align.hs @@ -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 diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Attributes.hs @@ -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 +-- (). 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) diff --git a/src/Diagrams/Backend/Show.hs b/src/Diagrams/Backend/Show.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/Show.hs @@ -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) diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Combinators.hs @@ -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 diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Path.hs @@ -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 diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Prelude.hs @@ -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 diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Segment.hs @@ -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)) diff --git a/src/Diagrams/Solve.hs b/src/Diagrams/Solve.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Solve.hs @@ -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? diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD.hs @@ -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 diff --git a/src/Diagrams/TwoD/Align.hs b/src/Diagrams/TwoD/Align.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Align.hs @@ -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 diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Arc.hs @@ -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)) diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Combinators.hs @@ -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) diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -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 diff --git a/src/Diagrams/TwoD/Model.hs b/src/Diagrams/TwoD/Model.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Model.hs @@ -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) -> ... diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Path.hs @@ -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) + diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Shapes.hs @@ -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" +-} diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Transform.hs @@ -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). diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Types.hs @@ -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 diff --git a/src/Diagrams/TwoD/Util.hs b/src/Diagrams/TwoD/Util.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Util.hs @@ -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) diff --git a/src/Diagrams/Util.hs b/src/Diagrams/Util.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Util.hs @@ -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