diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -47,3 +47,29 @@ * Bug fixes: + Issue 32 (mempty not behaving correctly within concatenations) + +0.4: 23 October 2011 + + * documentation fixes + + * New functions and primitives: + + + 'wedge' shape primitive + + 'fromDirection' function for converting angles to 2D unit vectors; + inverse function 'direction' generalized to return any Angle type + + New functions for computing and adjusting segment lengths + + 'scaleUToX' and 'scaleUToY' for doing uniform scales + resulting in a desired width or height. + + 'circlePath', 'reversePath', 'decoratePath' + + * New features: + + + Completely new and improved polygon generation API + + Cubic splines + + User-controllable path fill rules + + * Bug fixes: + + + fix incorrect corner case in arc generation + + fix incorrect reverseTrail function + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,6 @@ -Copyright 2011 diagrams-lib team: +Copyright (c) 2011 diagrams-lib team: + Claude Heiland-Allen Kanchalai Suveepattananont Scott Walck Ryan Yates diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,17 @@ +The standard library for diagrams, a Haskell embedded domain-specific +language for compositional, declarative drawing. See + + http://projects.haskell.org/diagrams/ + +for more information about the project, including installation +instructions, tutorials, a user manual, a gallery of example images, +and links to the mailing list, IRC channel, developer wiki and bug +tracker. + +The source repository is mirrored on both patch-tag (darcs) and github +(git): + + http://patch-tag.com/r/byorgey/diagrams-lib + https://github.com/byorgey/diagrams-lib + +Patches/pull requests welcome in either place. diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -1,5 +1,5 @@ Name: diagrams-lib -Version: 0.3 +Version: 0.4 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 @@ -16,8 +16,8 @@ Category: Graphics Build-type: Simple Cabal-version: >=1.6 -Extra-source-files: CHANGES -Tested-with: GHC == 6.12.3, GHC >= 7.0.2 && <= 7.0.3 +Extra-source-files: CHANGES, README +Tested-with: GHC == 6.12.3, GHC >= 7.0.2 && <= 7.0.3, GHC == 7.2.1 Source-repository head type: darcs location: http://patch-tag.com/r/byorgey/diagrams-lib @@ -29,6 +29,8 @@ Diagrams.Attributes, Diagrams.Segment, Diagrams.Path, + Diagrams.CubicSpline, + Diagrams.CubicSpline.Internal, Diagrams.Solve, Diagrams.Transform, Diagrams.BoundingBox, @@ -40,8 +42,10 @@ Diagrams.TwoD.Ellipse, Diagrams.TwoD.Arc, Diagrams.TwoD.Path, + Diagrams.TwoD.Polygons, Diagrams.TwoD.Shapes, - Diagrams.TwoD.Util, + Diagrams.TwoD.Vector, + Diagrams.TwoD.Size, Diagrams.TwoD.Model, Diagrams.TwoD.Text, Diagrams.TwoD.Image, @@ -50,13 +54,16 @@ Diagrams.ThreeD.Shapes, Diagrams.Util, Diagrams.Backend.Show - Build-depends: base >= 4.2 && < 4.4, + Build-depends: base >= 4.2 && < 4.5, containers >= 0.3 && < 0.5, - semigroups >= 0.3.4 && < 0.6, - diagrams-core >= 0.3 && < 0.4, - vector-space >= 0.7 && < 0.8, + array >= 0.3 && < 0.4, + semigroups >= 0.3.4 && < 0.9, + diagrams-core >= 0.4 && < 0.5, + vector-space >= 0.7.7 && < 0.8, + NumInstances >= 1.0 && < 1.1, colour >= 2.3.1 && < 2.4, data-default >= 0.2 && < 0.3, - pretty >= 1.0.1.2 && < 1.1, - newtype >= 0.2 && < 0.3 + pretty >= 1.0.1.2 && < 1.2, + newtype >= 0.2 && < 0.3, + tau >= 6.28 Hs-source-dirs: src diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -27,7 +27,7 @@ -- * n-ary operations , appends - , position, decorateTrail + , position, decorateTrail, decoratePath , cat, cat', CatOpts(..), CatMethod(..) ) where @@ -79,14 +79,15 @@ -- | @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. +-- 1-dimensional segment oriented along the vector @v@, with local +-- origin at its center. Useful for manually creating separation +-- between two diagrams. strut :: ( Backend b v, InnerSpace v , OrderedField (Scalar v) , Monoid m ) => v -> AnnDiagram b v m -strut v = phantom $ getBounds (Linear v) +strut v = phantom . translate ((-0.5) *^ v) . getBounds $ Linear v ------------------------------------------------------------ -- Combining two objects @@ -142,17 +143,26 @@ -- | 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 (|>) [0::Integer ..] . map (uncurry moveTo) +position :: (HasOrigin a, Monoid a) => [(Point (V a), a)] -> a +position = mconcat . map (uncurry moveTo) -- | Combine a list of diagrams (or paths) by using them to -- \"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 +-- each successive vertex of the trail. The first vertex of the +-- trail is placed at the origin. If the trail and list of objects +-- have different lengths, the extra tail of the longer one is +-- ignored. +decorateTrail :: (HasOrigin a, Monoid a) => Trail (V a) -> [a] -> a decorateTrail t = position . zip (trailVertices origin t) +-- | Combine a list of diagrams (or paths) by using them to +-- \"decorate\" a path, placing the local origin of one object at +-- each successive vertex of the path. If the path and list of objects +-- have different lengths, the extra tail of the longer one is +-- ignored. +decoratePath :: (HasOrigin a, Monoid a) => Path (V a) -> [a] -> a +decoratePath p = position . zip (concat $ pathVertices p) + -- | Methods for concatenating diagrams. data CatMethod = Cat -- ^ Normal catenation: simply put diagrams -- next to one another (possibly with a @@ -210,7 +220,7 @@ -- -- 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 :: (HasOrigin a, Boundable a, Monoid a) => V a -> [a] -> a cat v = cat' v def -- | Like 'cat', but taking an extra 'CatOpts' arguments allowing the @@ -230,10 +240,10 @@ -- 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) +cat' :: (HasOrigin a, Boundable a, Monoid a) => V a -> CatOpts (V a) -> [a] -> a cat' _ (CatOpts { catMethod = Cat }) [] = mempty -cat' _ (CatOpts { catMethod = Cat }) [d] = (0::Integer) |> d +cat' _ (CatOpts { catMethod = Cat }) [d] = d cat' v (CatOpts { catMethod = Cat, sep = s }) (x:xs) = foldl' (\d2 d1 -> d1 <> (moveOriginBy (origin .-. boundary v d1) @@ -242,13 +252,9 @@ ) d ds - where (d:ds) = reverse (zipWith (|>) [0::Integer ..] (x:xs')) + where (d:ds) = reverse (x:xs') xs' = map (align (negateV v)) xs cat' v (CatOpts { catMethod = Distrib, sep = s }) ds = decorateTrail (fromOffsets (repeat (withLength s v))) ds -- infinite trail, no problem for Haskell =D - --- XXX add documentation about how cat' (and vcat, hcat, --- decorateTrail, position...) also qualifies names with consecutive --- natural numbers diff --git a/src/Diagrams/CubicSpline.hs b/src/Diagrams/CubicSpline.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/CubicSpline.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TypeFamilies + , FlexibleContexts + #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.CubicSpline +-- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Generic functionality for constructing cubic splines +-- +----------------------------------------------------------------------------- +module Diagrams.CubicSpline + ( + -- * Constructing paths from cubic splines + cubicSpline + ) where + +import Diagrams.CubicSpline.Internal + +import Graphics.Rendering.Diagrams +import Diagrams.Segment +import Diagrams.Path + +import Control.Newtype +import Data.Monoid + +-- | Construct a spline path-like thing of cubic segments from a list of +-- vertices, with the first vertex as the starting point. The first +-- argument specifies whether the path should be closed. +-- See: +cubicSpline :: (PathLike p, Fractional (V p)) => Bool -> [Point (V p)] -> p +cubicSpline _ [] = mempty +cubicSpline closed ps = flattenBeziers . map f . solveCubicSplineCoefficients closed . map unpack $ ps + where + f [a,b,c,d] = [a, (3*a+b)/3, (3*a+2*b+c)/3, a+b+c+d] + flattenBeziers bs@((b:_):_) = pathLike (P b) False (map bez bs) + bez [a,b,c,d] = bezier3 (b - a) (c - a) (d - a) diff --git a/src/Diagrams/CubicSpline/Internal.hs b/src/Diagrams/CubicSpline/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/CubicSpline/Internal.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE TypeFamilies + , FlexibleContexts + #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.CubicSpline +-- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Generic functionality for constructing cubic splines +-- +----------------------------------------------------------------------------- +module Diagrams.CubicSpline.Internal + ( + -- * Solving for spline coefficents + solveTriDiagonal + , solveCyclicTriDiagonal + , solveCubicSplineDerivatives + , solveCubicSplineDerivativesClosed + , solveCubicSplineCoefficients + ) where + +import Control.Applicative +import Control.Newtype +import Data.Monoid +import Data.List +import Data.VectorSpace +import Data.NumInstances + +-- | Solves a system of the form 'A*X=D' for 'x' where 'A' is an +-- 'n' by 'n' matrix with 'bs' as the main diagonal and +-- 'as' the diagonal below and 'cs' the diagonal above. +-- See: +solveTriDiagonal :: Fractional a => [a] -> [a] -> [a] -> [a] -> [a] +solveTriDiagonal as (b0:bs) (c0:cs) (d0:ds) = h cs' ds' + where + cs' = c0 / b0 : f cs' as bs cs + f _ [_] _ _ = [] + f (c':cs') (a:as) (b:bs) (c:cs) = c / (b - c' * a) : f cs' as bs cs + + ds' = d0 / b0 : g ds' as bs cs' ds + g _ [] _ _ _ = [] + g (d':ds') (a:as) (b:bs) (c':cs') (d:ds) = (d - d' * a)/(b - c' * a) : g ds' as bs cs' ds + + h _ [d] = [d] + h (c:cs) (d:ds) = let xs@(x:_) = h cs ds in d - c * x : xs + +-- Helper that applies the passed function only to the last element of a list +modifyLast :: (a -> a) -> [a] -> [a] +modifyLast f [] = [] +modifyLast f [a] = [f a] +modifyLast f (a:as) = a : modifyLast f as + +-- Helper that builds a list of length n of the form: '[s,m,m,...,m,m,e]' +sparseVector :: Int -> a -> a -> a -> [a] +sparseVector n s m e + | n < 1 = [] + | otherwise = s : h (n - 1) + where + h 1 = [e] + h n = m : h (n - 1) + +-- | Solves a system similar to the tri-diagonal system using a special case +-- of the Sherman--Morrison formula . +-- This code is based on /Numerical Recpies in C/'s "cyclic" function in section 2.7. +solveCyclicTriDiagonal :: Fractional a => [a] -> [a] -> [a] -> [a] -> a -> a -> [a] +solveCyclicTriDiagonal as (b0:bs) cs ds alpha beta = zipWith ((+) . (fact *)) zs xs + where + l = length ds + gamma = -b0 + us = sparseVector l gamma 0 alpha + + bs' = (b0 - gamma) : modifyLast (subtract (alpha*beta/gamma)) bs + + xs@(x:_) = solveTriDiagonal as bs' cs ds + zs@(z:_) = solveTriDiagonal as bs' cs us + + fact = -(x + beta * last xs / gamma) / (1.0 + z + beta * last zs / gamma) + +-- | Use the tri-diagonal solver with the appropriate parameters for an open cubic spline. +solveCubicSplineDerivatives :: Fractional a => [a] -> [a] +solveCubicSplineDerivatives (x:xs) = solveTriDiagonal as bs as ds + where + as = replicate (l - 1) 1 + bs = 2 : replicate (l - 2) 4 ++ [2] + l = length ds + ds = zipWith f (xs ++ [last xs]) (x:x:xs) + f a b = 3*(a - b) + +-- | Use the cyclic-tri-diagonal solver with the appropriate parameters for a closed cubic spline. +solveCubicSplineDerivativesClosed :: Fractional a => [a] -> [a] +solveCubicSplineDerivativesClosed xs = solveCyclicTriDiagonal as bs as ds 1 1 + where + as = replicate (l - 1) 1 + bs = replicate l 4 + l = length xs + xs' = cycle xs + ds = take l $ zipWith f (drop 1 xs') (drop (l - 1) xs') + f a b = 3*(a - b) + +-- | Use the cyclic-tri-diagonal solver with the appropriate parameters for a closed cubic spline. +solveCubicSplineCoefficients :: Fractional a => Bool -> [a] -> [[a]] +solveCubicSplineCoefficients closed xs = + [ [x,d,3*(x1-x)-2*d-d1,2*(x-x1)+d+d1] + | (x,x1,d,d1) <- zip4 xs' (tail xs') ds' (tail ds') + ] + where + ds | closed = solveCubicSplineDerivativesClosed xs + | otherwise = solveCubicSplineDerivatives xs + close as | closed = as ++ [head as] + | otherwise = as + xs' = close xs + ds' = close ds diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -24,7 +24,7 @@ ( -- * Constructing path-like things - PathLike(..), fromOffsets, fromVertices, segmentsFromVertices + PathLike(..), fromSegments, fromOffsets, fromVertices, segmentsFromVertices , pathLikeFromTrail -- * Closeable things @@ -35,11 +35,12 @@ , Trail(..) - -- ** Destructing trails + -- ** Computing with trails , trailSegments' , trailOffsets, trailOffset , trailVertices, reverseTrail + , fixTrail -- * Paths @@ -50,10 +51,12 @@ , pathFromTrail , pathFromTrailAt - -- ** Destructing paths + -- ** Computing with paths , pathVertices , pathOffsets + , reversePath + , fixPath -- * Miscellaneous @@ -93,6 +96,10 @@ -> Bool -- ^ Should the path be closed? -> [Segment (V p)] -- ^ Segments of the path. -> p +-- | A list of points is path-like; this instance simply computes the +-- vertices of a path-like thing. +instance VectorSpace v => PathLike [Point v] where + pathLike start cl segs = trailVertices start (pathLike start cl segs) -- | Construct an open path-like thing with the origin as a starting -- point. @@ -105,13 +112,14 @@ fromOffsets = pathLike origin False . map Linear -- | Construct a path-like thing of linear segments from a list of --- vertices, with the first vertex as the starting point. The first --- argument specifies whether the path should be closed. +-- vertices, with the first vertex as the starting point. fromVertices :: PathLike p => [Point (V p)] -> p fromVertices [] = mempty fromVertices vvs@(v:_) = pathLike v False (segmentsFromVertices vvs) --- | Construct a list of segments from a (non-empty) list of vertices. +-- | Construct a list of linear segments from a list of vertices. The +-- input list must contain at least two points to generate a +-- non-empty list of segments. segmentsFromVertices :: AdditiveGroup v => [Point v] -> [Segment v] segmentsFromVertices [] = [] segmentsFromVertices vvs@(_:vs) = map Linear (zipWith (flip (.-.)) vvs vs) @@ -203,15 +211,30 @@ -- | Reverse a trail's direction of travel. reverseTrail :: AdditiveGroup v => Trail v -> Trail v -reverseTrail t = t { trailSegments = (fmap . fmap) negateV . reverse - $ trailSegments t - } +reverseTrail t@(Trail {trailSegments = []}) = t +reverseTrail t@(Trail {trailSegments = ss}) + | isClosed t = t { trailSegments = straight (trailOffset t) : reverseSegs ss } + | otherwise = t { trailSegments = reverseSegs $ ss } + where reverseSegs = fmap reverseSegment . reverse +-- | Reverse a trail with a fixed starting point. +reverseRootedTrail :: AdditiveGroup v => (Point v, Trail v) -> (Point v, Trail v) +reverseRootedTrail (p, t) + | isClosed t = (p, reverseTrail t) + | otherwise = (p .+^ trailOffset t, reverseTrail t) + -- | Convert a trail to any path-like thing. @pathLikeFromTrail@ is the -- identity on trails. pathLikeFromTrail :: PathLike p => Trail (V p) -> p pathLikeFromTrail t = pathLike origin (isClosed t) (trailSegments t) +-- | Convert a starting point and a trail into a list of fixed segments. +fixTrail :: AdditiveGroup v => Point v -> Trail v -> [FixedSegment v] +fixTrail start tr = zipWith mkFixedSeg (trailVertices start tr) + (trailSegments tr ++ closeSeg) + where closeSeg | isClosed tr = [Linear . negateV . trailOffset $ tr] + | otherwise = [] + ------------------------------------------------------------ -- Paths ------------------------------------------------- ------------------------------------------------------------ @@ -270,16 +293,24 @@ pathFromTrailAt t p = Path [(p, t)] ------------------------------------------------------------ --- Destructing paths ------------------------------------- +-- Computing with paths ---------------------------------- ------------------------------------------------------------ -- | Extract the vertices of a path. -pathVertices :: (AdditiveGroup v, Ord v) => Path v -> [[Point v]] +pathVertices :: AdditiveGroup v => Path v -> [[Point v]] pathVertices = map (uncurry trailVertices) . pathTrails -- | Compute the total offset of each trail comprising a path. pathOffsets :: AdditiveGroup v => Path v -> [v] pathOffsets = map (trailOffset . snd) . pathTrails + +-- | Reverse the direction of all the component trails of a path. +reversePath :: AdditiveGroup v => Path v -> Path v +reversePath = (over Path . map) reverseRootedTrail + +-- | Convert a path into a list of lists of 'FixedSegment's. +fixPath :: AdditiveGroup v => Path v -> [[FixedSegment v]] +fixPath = map (uncurry fixTrail) . unpack ------------------------------------------------------------ -- Other functions --------------------------------------- diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -34,6 +34,9 @@ -- | Trails and paths. , module Diagrams.Path + -- | Cubic splines. + , module Diagrams.CubicSpline + -- | Some additional transformation-related functions, like -- conjugation of transformations. , module Diagrams.Transform @@ -69,6 +72,7 @@ import Diagrams.Combinators import Diagrams.Segment import Diagrams.Path +import Diagrams.CubicSpline import Diagrams.Transform import Diagrams.BoundingBox import Diagrams.TwoD diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -23,14 +23,33 @@ -- * Computing with segments , atParam, segOffset + , reverseSegment , splitAtParam, arcLength + , arcLengthToParam + -- * Adjusting segments + , adjustSegment + , AdjustOpts(..) + , AdjustMethod(..) + , AdjustSide(..) + + , adjustSegmentToParams + + -- * Fixed (absolutely located) segments + + , FixedSegment(..) + , mkFixedSeg + , fAtParam + ) where import Graphics.Rendering.Diagrams import Diagrams.Solve +import Diagrams.Util +import Data.Default +import Data.AffineSpace import Data.VectorSpace import Control.Applicative (liftA2) @@ -93,6 +112,11 @@ segOffset (Linear v) = v segOffset (Cubic _ _ v) = v +-- | Reverse the direction of a segment. +reverseSegment :: AdditiveGroup v => Segment v -> Segment v +reverseSegment (Linear v) = Linear (negateV v) +reverseSegment (Cubic c1 c2 x2) = Cubic (c2 ^-^ x2) (c1 ^-^ x2) (negateV x2) + ------------------------------------------------------------ -- Computing segment bounds ------------------------------ ------------------------------------------------------------ @@ -119,6 +143,26 @@ Set equal to zero, use quadratic formula. -} +-- | The bounding function for a segment is based at the segment's +-- start. +instance (InnerSpace v, OrderedField (Scalar v)) => Boundable (Segment v) where + + 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)) + +------------------------------------------------------------ +-- Manipulating segments +------------------------------------------------------------ + -- | '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@. @@ -130,6 +174,12 @@ -- > where (l,r) = splitAtParam s t -- -- That is to say, the parameterization scales linearly with splitting. +-- +-- 'splitAtParam' can also be used with parameters outside the range +-- (0,1). For example, using the parameter @2@ gives two result +-- segments where the first is the original segment extended to the +-- parameter 2, and the second result segment travels /backwards/ +-- from the end of the first to the end of the original segment. splitAtParam :: (VectorSpace v) => Segment v -> Scalar v -> (Segment v, Segment v) splitAtParam (Linear x1) t = (left, right) where left = Linear p @@ -159,19 +209,141 @@ ub = sum (map magnitude [c1, c2 ^-^ c1, x2 ^-^ c2]) lb = magnitude x2 +-- | @'arcLengthToParam' s l m@ converts the absolute arc length @l@, +-- measured from the segment starting point, to a parameter on the +-- segment @s@, with accuracy of at least plus or minus @m@. Works +-- for /any/ arc length, and may return any parameter value (not +-- just parameters between 0 and 1). +arcLengthToParam :: (InnerSpace v, Floating (Scalar v), Ord (Scalar v), AdditiveGroup v) + => Segment v -> Scalar v -> Scalar v -> Scalar v +arcLengthToParam s _ m | arcLength s m == 0 = 0.5 +arcLengthToParam s@(Linear {}) len m = len / arcLength s m +arcLengthToParam s@(Cubic {}) len m + | len == 0 = 0 + | len < 0 = - arcLengthToParam (fst (splitAtParam s (-1))) (-len) m + | abs (len - slen) < m = 1 + | len > slen = 2 * arcLengthToParam (fst (splitAtParam s 2)) len m + | len < ll = (*0.5) $ arcLengthToParam l len m + | otherwise = (+0.5) . (*0.5) $ arcLengthToParam r (len - ll) m + where (l,r) = splitAtParam s 0.5 + ll = arcLength l m + slen = arcLength s m --- | The bounding function for a segment is based at the segment's --- start. -instance (InnerSpace v, OrderedField (Scalar v)) => Boundable (Segment v) where +-- Note, the above seems to be quite slow since it duplicates a lot of +-- work. We could trade off some time for space by building a tree of +-- parameter values (up to a certain depth...) - getBounds (s@(Linear {})) = Bounds $ \v -> - maximum . map (\t -> ((s `atParam` t) <.> v) / magnitudeSq v) $ [0,1] +-------------------------------------------------- +-- Adjusting segment length +-------------------------------------------------- - 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)) +-- | What method should be used for adjusting a segment, trail, or +-- path? +data AdjustMethod v = ByParam (Scalar v) -- ^ Extend by the given parameter value + -- (use a negative parameter to shrink) + | ByAbsolute (Scalar v) -- ^ Extend by the given arc length + -- (use a negative length to shrink) + | ToAbsolute (Scalar v) -- ^ Extend or shrink to the given + -- arc length + +-- | Which side of a segment, trail, or path should be adjusted? +data AdjustSide = Start -- ^ Adjust only the beginning + | End -- ^ Adjust only the end + | Both -- ^ Adjust both sides equally + deriving (Show, Read, Eq, Ord, Bounded, Enum) + +-- | How should a segment, trail, or path be adjusted? +data AdjustOpts v = ALO { adjMethod :: AdjustMethod v + , adjSide :: AdjustSide + , adjOptsvProxy__ :: Proxy v + } + +instance Fractional (Scalar v) => Default (AdjustMethod v) where + def = ByParam 0.2 + +instance Default AdjustSide where + def = Both + +instance Fractional (Scalar v) => Default (AdjustOpts v) where + def = ALO def def Proxy + +-- | Adjust the length of a segment. The second parameter is an +-- option record which controls how the adjustment should be +-- performed; see 'AdjustOpts'. +adjustSegment :: (InnerSpace v, OrderedField (Scalar v)) + => Segment v -> AdjustOpts v -> Segment v +adjustSegment s opts = adjustSegmentToParams s t1 t2 + where t1 = case opts of + (ALO _ End _) -> 0 + (ALO (ByParam p) Start _) -> -p + (ALO (ByParam p) Both _) -> -p/2 + (ALO (ByAbsolute len) Start _) -> arcLengthToParam s (-len) eps + (ALO (ByAbsolute len) Both _) -> arcLengthToParam s (-len/2) eps + (ALO (ToAbsolute len) Start _) -> arcLengthToParam s (arcLength s eps - len) eps + (ALO (ToAbsolute len) Both _) -> arcLengthToParam s ((arcLength s eps - len)/2) eps + t2 = case opts of + (ALO _ Start _) -> 1 + (ALO (ByParam p) End _) -> 1 + p + (ALO (ByParam p) Both _) -> 1 + p/2 + (ALO (ByAbsolute len) End _) -> 1 - arcLengthToParam (reverseSegment s) (-len) eps + (ALO (ByAbsolute len) Both _) -> 1 - (arcLengthToParam (reverseSegment s) (-len) eps)/2 + (ALO (ToAbsolute len) End _) -> 1 - arcLengthToParam (reverseSegment s) (arcLength s eps - len) eps + (ALO (ToAbsolute len) Both _) -> 1 - arcLengthToParam (reverseSegment s) ((arcLength s eps - len)/2) eps + eps = 1/10^(10 :: Integer) + +-- | Given a segment and parameters @t1@, @t2@, produce the segment +-- which lies on the (infinitely extended) original segment +-- beginning at @t1@ and ending at @t2@. +adjustSegmentToParams :: (Fractional (Scalar v), VectorSpace v) + => Segment v -> Scalar v -> Scalar v -> Segment v +adjustSegmentToParams s t1 t2 = snd (splitAtParam (fst (splitAtParam s t2)) (t1/t2)) + +------------------------------------------------------------ +-- Fixed segments +------------------------------------------------------------ + +-- | @FixedSegment@s are like 'Segment's except that they have +-- absolute locations. +data FixedSegment v = FLinear (Point v) (Point v) + | FCubic (Point v) (Point v) (Point v) (Point v) + deriving Show + +type instance V (FixedSegment v) = v + +instance HasLinearMap v => Transformable (FixedSegment v) where + transform t (FLinear p1 p2) = FLinear (transform t p1) (transform t p2) + transform t (FCubic p1 c1 c2 p2) = FCubic (transform t p1) + (transform t c1) + (transform t c2) + (transform t p2) + +instance VectorSpace v => HasOrigin (FixedSegment v) where + moveOriginTo o (FLinear p1 p2) = FLinear (moveOriginTo o p1) + (moveOriginTo o p2) + moveOriginTo o (FCubic p1 c1 c2 p2) = FCubic (moveOriginTo o p1) + (moveOriginTo o c1) + (moveOriginTo o c2) + (moveOriginTo o p2) + +-- instance Boundable (FixedSegment v) where + -- XXX write me + +-- | Create a 'FixedSegment' from a starting point and a 'Segment'. +mkFixedSeg :: AdditiveGroup v => Point v -> Segment v -> FixedSegment v +mkFixedSeg p (Linear v) = FLinear p (p .+^ v) +mkFixedSeg p (Cubic c1 c2 x2) = FCubic p (p .+^ c1) (p .+^ c2) (p .+^ x2) + +-- | Compute the point on a fixed segment at a given parameter. A +-- parameter of 0 corresponds to the starting point and 1 corresponds +-- to the ending point. +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 diff --git a/src/Diagrams/Solve.hs b/src/Diagrams/Solve.hs --- a/src/Diagrams/Solve.hs +++ b/src/Diagrams/Solve.hs @@ -17,6 +17,8 @@ import Data.List (maximumBy) import Data.Ord (comparing) +import Math.Tau + ------------------------------------------------------------ -- Quadratic formula ------------------------------------------------------------ @@ -85,7 +87,7 @@ 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) + trig k = 2 * sqrt(-p/3) * cos(1/3*acos(3*q/(2*p)*sqrt(-3/p)) - k*tau/3) - b/(3*a) cubert x | x < 0 = -((-x)**(1/3)) diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeSynonymInstances + , FlexibleInstances , TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/src/Diagrams/Transform.hs b/src/Diagrams/Transform.hs --- a/src/Diagrams/Transform.hs +++ b/src/Diagrams/Transform.hs @@ -25,9 +25,9 @@ -- | Carry out some transformation \"under\" another one: @f ``under`` -- t@ first applies @t@, then @f@, then the inverse of @t@. For --- example, @'rotateBy' (1/3) ``under`` 'translationX' 1@ is --- equivalent to a rotation by 120 degrees about the point --- @(-1,0)@ (you may have to think about this for a minute =). +-- example, @'scaleX' 2 ``under`` 'rotationBy' (-1/8 :: CircleFrac)@ +-- is the transformation which scales by a factor of 2 along the +-- diagonal line y = x. -- -- Note that -- diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -34,6 +34,9 @@ -- * "Diagrams.TwoD.Path" exports various operations on -- two-dimensional paths when viewed as regions of the plane. -- +-- * "Diagrams.TwoD.Polygons" defines general algorithms for drawing +-- various types of polygons. +-- -- * "Diagrams.TwoD.Shapes" defines other two-dimensional shapes, -- e.g. various polygons. -- @@ -41,10 +44,12 @@ -- -- * "Diagrams.TwoD.Image" allows importing external images into diagrams. -- --- * "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.Vector" defines some special 2D vectors and +-- functions for converting between vectors and angles. -- +-- * "Diagrams.TwoD.Size" defines functions for working with the +-- size of 2D objects. +-- -- * "Diagrams.TwoD.Model" defines some aids for visualizing -- diagrams' internal model (local origins, bounding regions, -- etc.) @@ -53,7 +58,8 @@ module Diagrams.TwoD ( -- * R^2 R2, P2, T2 - , unitX, unitY, unit_X, unit_Y, direction + , unitX, unitY, unit_X, unit_Y + , direction, fromDirection, e -- * Angles , tau @@ -64,6 +70,7 @@ -- * Paths -- ** Stroking , stroke, stroke', strokeT, strokeT' + , FillRule(..), fillRule , StrokeOpts(..) -- ** Clipping @@ -76,20 +83,35 @@ -- ** Circle-ish things , unitCircle , circle + , circlePath , ellipse , ellipseXY , arc + , wedge -- ** General polygons - , polygon, polygonVertices - , PolygonOpts(..), PolygonOrientation(..) + , polygon, polyVertices + , PolygonOpts(..), PolyType(..), PolyOrientation(..) - -- ** Special polygons - , unitSquare + -- ** Star polygons + , StarOpts(..), star + + -- ** Regular polygons + , regPoly + , eqTriangle , square + , pentagon + , hexagon + , septagon + , octagon + , nonagon + , decagon + , hendecagon + , dodecagon + + -- ** Other special polygons + , unitSquare , rect - , starPolygon - , eqTriangle -- ** Other shapes , roundedRect @@ -109,6 +131,7 @@ , scalingY, scaleY , scaling, scale , scaleToX, scaleToY + , scaleUToX, scaleUToY -- ** Translation , translationX, translateX , translationY, translateY @@ -144,15 +167,19 @@ ) where +import Math.Tau + import Diagrams.TwoD.Types import Diagrams.TwoD.Path import Diagrams.TwoD.Ellipse import Diagrams.TwoD.Arc +import Diagrams.TwoD.Polygons import Diagrams.TwoD.Shapes import Diagrams.TwoD.Transform import Diagrams.TwoD.Align import Diagrams.TwoD.Combinators -import Diagrams.TwoD.Util +import Diagrams.TwoD.Vector +import Diagrams.TwoD.Size import Diagrams.TwoD.Model import Diagrams.TwoD.Text import Diagrams.TwoD.Image diff --git a/src/Diagrams/TwoD/Adjust.hs b/src/Diagrams/TwoD/Adjust.hs --- a/src/Diagrams/TwoD/Adjust.hs +++ b/src/Diagrams/TwoD/Adjust.hs @@ -21,9 +21,8 @@ import Diagrams.Util ((#)) import Diagrams.TwoD.Types (R2) -import Diagrams.TwoD.Util (size2D, center2D) +import Diagrams.TwoD.Size (size2D, center2D, SizeSpec2D(..)) import Diagrams.TwoD.Text (fontSize) -import Diagrams.TwoD.Util (SizeSpec2D(..)) import Data.AffineSpace ((.-.)) diff --git a/src/Diagrams/TwoD/Align.hs b/src/Diagrams/TwoD/Align.hs --- a/src/Diagrams/TwoD/Align.hs +++ b/src/Diagrams/TwoD/Align.hs @@ -37,7 +37,7 @@ import Graphics.Rendering.Diagrams import Diagrams.TwoD.Types -import Diagrams.TwoD.Util +import Diagrams.TwoD.Vector import Diagrams.Align import Data.VectorSpace diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -13,18 +13,25 @@ module Diagrams.TwoD.Arc ( arc , bezierFromSweep + + , circlePath + + , wedge ) where import Graphics.Rendering.Diagrams +import Math.Tau + import Diagrams.TwoD.Types import Diagrams.TwoD.Transform -import Diagrams.TwoD.Util +import Diagrams.TwoD.Vector (unitX, e) import Diagrams.Path import Diagrams.Segment +import Diagrams.Util ((#), (<>)) -import Data.VectorSpace((^-^)) +import Data.VectorSpace((^-^), (*^), negateV) -- For details of this approximation see: -- http://www.tinaja.com/glib/bezcirc2.pdf @@ -44,14 +51,14 @@ -- 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. +-- 0.0001 the empty list results. If the sweep is greater than tau +-- then it is truncated to tau. bezierFromSweep :: Rad -> [Segment R2] bezierFromSweep s | s > tau = bezierFromSweep tau | s < 0 = fmap reflectY . bezierFromSweep $ (-s) - | s < tau/4 = [bezierFromSweepQ1 s] | s < 0.0001 = [] + | s < tau/4 = [bezierFromSweepQ1 s] | otherwise = bezierFromSweepQ1 (tau/4) : map (rotateBy (1/4)) (bezierFromSweep (max (s - tau/4) 0)) @@ -60,9 +67,9 @@ 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 + to one quarter of a circle. 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 + B. Use as much of the sweep in quarter-circle 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 @@ -86,3 +93,15 @@ arc start end = pathLike (rotate start $ P unitX) False (trailSegments $ arcT start end) + +-- | Create a closed circular path of the given radius, centered at +-- the origin, beginning at (r,0). +circlePath :: (PathLike p, Closeable p, V p ~ R2, Transformable p) => Double -> p +circlePath r = arc 0 (tau::Rad) # close # scale r + +-- | Create a circular wedge of the given radius, beginning at the +-- first angle and extending counterclockwise to the second. +wedge :: (Angle a, PathLike p, V p ~ R2) => Double -> a -> a -> p +wedge r a1 a2 = pathLikeFromTrail $ fromOffsets [r *^ e a1] + <> arc a1 a2 # scale r + <> fromOffsets [r *^ negateV (e a2)] diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -30,7 +30,8 @@ import Graphics.Rendering.Diagrams import Diagrams.TwoD.Types -import Diagrams.TwoD.Util +import Diagrams.TwoD.Vector (unitX, unitY) + import Diagrams.Combinators import Data.VectorSpace @@ -66,17 +67,17 @@ -- * For more control over the spacing, see 'hcat''. -- -- * To align the diagrams vertically (or otherwise), use alignment --- combinators (such as 'alignT' or 'alignB') from --- "Diagrams.TwoD.Align" before applying 'hcat'. +-- combinators (such as 'alignT' or 'alignB') 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 :: (HasOrigin a, Boundable 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' :: (HasOrigin a, Boundable 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, @@ -86,25 +87,27 @@ -- * For more control over the spacing, see 'vcat''. -- -- * To align the diagrams horizontally (or otherwise), use alignment --- combinators (such as 'alignL' or 'alignR') from --- "Diagrams.TwoD.Align" before applying 'vcat'. +-- combinators (such as 'alignL' or 'alignR') 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 :: (HasOrigin a, Boundable 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' :: (HasOrigin a, Boundable 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. Note --- that @strutX (-w)@ behaves the same as @strutX w@. +-- | @strutX d@ is an empty diagram with width @d@, height 0, and a +-- centered local origin. Note that @strutX (-w)@ behaves the same as +-- @strutX w@. strutX :: (Backend b R2, Monoid m) => Double -> AnnDiagram b R2 m strutX d = strut (d,0) --- | @strutY d@ is an empty diagram with height @d@ and width 0. Note --- that @strutX (-w)@ behaves the same as @strutX w@. +-- | @strutY d@ is an empty diagram with height @d@, width 0, and a +-- centered local origin. Note that @strutX (-w)@ behaves the same as +-- @strutX w@. strutY :: (Backend b R2, Monoid m) => Double -> AnnDiagram b R2 m strutY d = strut (0,d) diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -46,6 +46,8 @@ import Data.VectorSpace (magnitudeSq, magnitude, (^-^)) +import Math.Tau + -- | An ellipse is represented by an affine transformation acting on -- the unit circle. data Ellipse = Ellipse T2 @@ -109,7 +111,7 @@ -- will be in the range [0, tau/2). ellipseAngle :: Ellipse -> Rad ellipseAngle ell - | y < 0 = Rad $ pi + atan2 y x + | y < 0 = Rad $ tau/2 + atan2 y x | otherwise = Rad $ atan2 y x where ((x,y),_) = ellipseAxes ell diff --git a/src/Diagrams/TwoD/Image.hs b/src/Diagrams/TwoD/Image.hs --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -24,7 +24,7 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Path import Diagrams.TwoD.Shapes -import Diagrams.TwoD.Util (SizeSpec2D(..)) +import Diagrams.TwoD.Size (SizeSpec2D(..)) import Diagrams.Util import Data.AffineSpace ((.-.)) diff --git a/src/Diagrams/TwoD/Model.hs b/src/Diagrams/TwoD/Model.hs --- a/src/Diagrams/TwoD/Model.hs +++ b/src/Diagrams/TwoD/Model.hs @@ -22,7 +22,7 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Ellipse -import Diagrams.TwoD.Util +import Diagrams.TwoD.Size (size2D) import Diagrams.TwoD.Text import Diagrams.Attributes import Diagrams.Util @@ -64,8 +64,7 @@ showLabels :: (Renderable Text b, Backend b R2) => AnnDiagram b R2 m -> AnnDiagram b R2 Any -showLabels d = (fontSize (max (w/40) (h/40)) - . mconcat +showLabels d = (mconcat . map (\(n,p) -> text (show n) # translate (p .-. origin)) . concatMap (\(n,ps) -> zip (repeat n) ps) . (map . second . map) fst @@ -75,7 +74,6 @@ (fmap (const (Any False)) d) where NameMap m = names d - (w,h) = size2D d -- XXX finish: diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -23,9 +23,13 @@ stroke, stroke', strokeT, strokeT' + -- ** Stroke options + + , FillRule(..) + , FillRuleA(..), getFillRule, fillRule , StrokeOpts(..) - -- * Inside/outside testing + -- ** Inside/outside testing , isInsideWinding, isInsideEvenOdd @@ -36,14 +40,15 @@ import Graphics.Rendering.Diagrams +import Math.Tau + import Diagrams.Segment import Diagrams.Path import Diagrams.TwoD.Types import Diagrams.Solve -import Data.AdditiveGroup -import Data.VectorSpace import Data.AffineSpace +import Data.VectorSpace import Data.Semigroup hiding ((<>)) import Control.Applicative (liftA2) @@ -80,13 +85,13 @@ -- -- 'StrokeOpts' is an instance of 'Default', so @stroke' 'with' { -- ... }@ syntax may be used. -stroke' :: (Renderable (Path R2) b, Atomic a) => StrokeOpts a -> Path R2 -> Diagram b R2 +stroke' :: (Renderable (Path R2) b, IsName a) => StrokeOpts a -> Path R2 -> Diagram b R2 stroke' opts p = mkAD (Prim p) (getBounds p) (fromNames . concat $ zipWith zip (vertexNames opts) (pathVertices p)) - (Query $ Any . flip isInsideWinding p) + (Query $ Any . flip (runFillRule (queryFillRule opts)) p) -- | A record of options that control how a path is stroked. -- @StrokeOpts@ is an instance of 'Default', so a @StrokeOpts@ @@ -108,11 +113,22 @@ -- so on. -- -- The default value is the empty list. + + , queryFillRule :: FillRule + -- ^ The fill rule used for determining + -- which points are inside the path. + -- The default is 'Winding'. NOTE: for + -- now, this only affects the resulting + -- diagram's 'Query', /not/ how it will + -- be drawn! To set the fill rule + -- determining how it is to be drawn, + -- use the 'fillRule' function. } instance Default (StrokeOpts a) where def = StrokeOpts - { vertexNames = [] + { vertexNames = [] + , queryFillRule = Winding } -- | A composition of 'stroke' and 'pathFromTrail' for conveniently @@ -129,7 +145,7 @@ -- | A composition of 'stroke'' and 'pathFromTrail' for conveniently -- converting a trail directly into a diagram. -strokeT' :: (Renderable (Path R2) b, Atomic a) +strokeT' :: (Renderable (Path R2) b, IsName a) => StrokeOpts a -> Trail R2 -> Diagram b R2 strokeT' opts = stroke' opts . pathFromTrail @@ -137,6 +153,35 @@ -- Inside/outside testing ------------------------------------------------------------ +-- | Enumeration of algorithms or \"rules\" for determining which +-- points lie in the interior of a (possibly self-intersecting) +-- closed path. +data FillRule = Winding -- ^ Interior points are those with a nonzero + -- /winding/ /number/. See + -- . + | EvenOdd -- ^ Interior points are those where a ray + -- extended infinitely in a particular + -- direction crosses the path an odd number + -- of times. See + -- . + +runFillRule :: FillRule -> P2 -> Path R2 -> Bool +runFillRule Winding = isInsideWinding +runFillRule EvenOdd = isInsideEvenOdd + +newtype FillRuleA = FillRuleA (Last FillRule) + deriving (Typeable, Semigroup) +instance AttributeClass FillRuleA + +-- | Extract the fill rule from a 'FillRuleA' attribute. +getFillRule :: FillRuleA -> FillRule +getFillRule (FillRuleA (Last r)) = r + +-- | Specify the fill rule that should be used for determining which +-- points are inside a path. +fillRule :: HasStyle a => FillRule -> a -> a +fillRule = applyAttr . FillRuleA . Last + cross :: R2 -> R2 -> Double cross (x,y) (x',y') = x * y' - y * x' @@ -157,26 +202,6 @@ 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 @@ -190,9 +215,7 @@ trailCrossings _ (_, t) | not (isClosed t) = 0 trailCrossings p@(P (x,y)) (start, tr) - = sum . map test - $ zipWith mkFixedSeg (trailVertices start tr) - (trailSegments tr ++ [Linear . negateV . trailOffset $ tr]) + = sum . map test $ fixTrail start tr where test (FLinear a@(P (_,ay)) b@(P (_,by))) | ay <= y && by > y && isLeft a b > 0 = 1 @@ -213,9 +236,9 @@ ^+^ (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 + in case () of _ | (0 < ang && ang < tau/2 && t < 1) -> 1 + | (-tau/2 < ang && ang < 0 && t > 0) -> -1 + | otherwise -> 0 isLeft a b = cross (b .-. a) (p .-. a) diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Polygons.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE TypeFamilies + , ScopedTypeVariables + , DeriveFunctor + , ExistentialQuantification + #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Polygon +-- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- General API for creating various types of polygons. +-- +----------------------------------------------------------------------------- + +module Diagrams.TwoD.Polygons( + -- * Polygons + PolyType(..) + , PolyOrientation(..) + , PolygonOpts(..) + , polyVertices + + , polygon + + -- ** Generating polygon vertices + + , polyPolarVs + , polySidesVs, polySidesVs' + , polyRegularVs + + , orient + + -- * Star polygons + , StarOpts(..) + , star + + -- ** Function graphs + , GraphPart(..) + , orbits, mkGraph + + -- * Utility + , centroid + ) where + +import Data.Ord (comparing) +import Data.List (maximumBy) +import Data.Maybe (catMaybes) +import Data.Monoid (mconcat) + +import Math.Tau + +import Control.Arrow ((&&&)) +import Control.Monad (forM, liftM) + +import Control.Monad.ST (runST, ST) +import Data.Array.ST (STUArray, newArray, readArray, writeArray) +import Control.Newtype (pack, unpack) + +import Data.AffineSpace ((.-.), (.+^)) +import Data.VectorSpace (sumV, magnitude, normalized, project, (^/), (<.>), (^*)) +import Data.Default + +import Graphics.Rendering.Diagrams + +import Diagrams.TwoD.Types +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Vector (unitX, unitY, unit_Y) +import Diagrams.Path +import Diagrams.Util ((#)) + +-- | Method used to determine the vertices of a polygon. +data PolyType = forall a. Angle a => PolyPolar [a] [Double] + -- ^ A \"polar\" polygon. + -- + -- * The first argument is a list of /central/ + -- /angles/ from each vertex to the next. + -- + -- * The second argument is a list of /radii/ from + -- the origin to each successive vertex. + -- + -- To construct an /n/-gon, use a list of /n-1/ + -- angles and /n/ radii. Extra angles or radii + -- are ignored. + -- + -- Cyclic polygons (with all vertices lying on a + -- circle) can be constructed using a second + -- argument of @(repeat r)@. + + | forall a. Angle a => PolySides [a] [Double] + -- ^ A polygon determined by the distance between + -- successive vertices and the angles formed by + -- each three successive vertices. In other + -- words, a polygon specified by \"turtle + -- graphics\": go straight ahead x1 units; turn by + -- angle a1; go straght ahead x2 units; turn by + -- angle a2; etc. The polygon will be centered at + -- the /centroid/ of its vertices. + -- + -- * The first argument is a list of /vertex/ + -- /angles/, giving the angle at each vertex + -- from the previous vertex to the next. The + -- first angle in the list is the angle at the + -- /second/ vertex; the first edge always starts + -- out heading in the positive y direction from + -- the first vertex. + -- + -- * The second argument is a list of distances + -- between successive vertices. + -- + -- To construct an /n/-gon, use a list of /n-2/ + -- angles and /n-1/ edge lengths. Extra angles or + -- lengths are ignored. + + | PolyRegular Int Double + -- ^ A regular polygon with the given number of + -- sides (first argument) and the given radius + -- (second argument). + +-- | Determine how a polygon should be oriented. +data PolyOrientation = NoOrient -- ^ No special orientation; the first + -- vertex will be at (1,0). + -- This is the default. + | OrientH -- ^ Orient /horizontally/, so the + -- bottommost edge is parallel to + -- the x-axis. + | OrientV -- ^ Orient /vertically/, so the + -- leftmost edge is parallel to the + -- y-axis. + | OrientTo R2 -- ^ Orient so some edge is + -- /facing/ /in/ /the/ /direction/ + -- /of/, that is, perpendicular + -- to, the given vector. + deriving (Eq, Ord, Show, Read) + +-- | Options for specifying a polygon. +data PolygonOpts = PolygonOpts + { polyType :: PolyType + -- ^ Specification for the polygon's vertices. + + , polyOrient :: PolyOrientation + -- ^ Should a rotation be applied to the + -- polygon in order to orient it in a + -- particular way? + + , polyCenter :: P2 + -- ^ Should a translation be applied to the + -- polygon in order to place the center at a + -- particular location? + } + +-- | The default polygon is a regular pentagon of radius 1, centered +-- at the origin, aligned to the x-axis. +instance Default PolygonOpts where + def = PolygonOpts (PolyRegular 5 1) OrientH origin + +-- | Generate the vertices of a polygon. See 'PolygonOpts' for more +-- information. +polyVertices :: PolygonOpts -> [P2] +polyVertices po = moveTo (polyCenter po) ori + where + ps = case polyType po of + PolyPolar ans szs -> polyPolarVs ans szs + PolySides ans szs -> polySidesVs ans szs + PolyRegular n r -> polyRegularVs n r + ori = case polyOrient po of + OrientH -> orient unit_Y ps + OrientV -> orient unitX ps + OrientTo v -> orient v ps + NoOrient -> ps + +polygon :: (PathLike p, V p ~ R2) => PolygonOpts -> p +polygon opts = case pts of + [] -> pathLike origin True [] + (p1:_) -> pathLike p1 True (segmentsFromVertices pts) + where pts = polyVertices opts + +-- | Generate the vertices of a polygon specified by polar data +-- (central angles and radii). See 'PolyPolar'. +polyPolarVs :: Angle a => [a] -> [Double] -> [P2] +polyPolarVs ans ls = zipWith (\a l -> P . rotate a . scale l $ unitX) + (scanl (+) 0 ans) + ls + +-- | Generate the vertices of a polygon specified by side length and +-- angles, with the origin corresponding to the first vertex. See +-- 'PolySides'. +polySidesVs' :: Angle a => [a] -> [Double] -> [P2] +polySidesVs' ans ls = scanl (.+^) origin + $ zipWith rotate ans' (map (unitY ^*) ls) + where + ans' = scanl (+) 0 ans + +-- | Generate the vertices of a polygon specified by side length and +-- angles, with the origin placed at the centroid. See 'PolySides'. +polySidesVs :: Angle a => [a] -> [Double] -> [P2] +polySidesVs ans ls = p0 # moveOriginTo (centroid p0) + where p0 = polySidesVs' ans ls + +-- | Generate the vertices of a regular polygon. See 'PolyRegular'. +polyRegularVs :: Int -> Double -> [P2] +polyRegularVs n r = polyPolarVs (take (n-1) . repeat $ (tau::Rad) / fromIntegral n) + (repeat r) + +-- | Orient a list of points, rotating them as little as possible. +-- The points are rotated so that the edge furthest in the direction +-- of the given vector is perpendicular to it. (Note: this may do odd +-- things to non-convex lists of points.) +orient :: R2 -> [P2] -> [P2] +orient _ [] = [] +orient v xs = rotate a xs + where + (n1,x,n2) = maximumBy (comparing (distAlong v . sndOf3)) + (zip3 (tail xs ++ take 1 xs) xs (last xs : init xs)) + distAlong w (P p) = signum (w <.> p) * magnitude (project w p) + x' = maximumBy (comparing (distAlong v)) [n1, n2] + e = x' .-. x + th = Rad $ acos ((e <.> normalized v) / magnitude e) + a | rightTurn (x .+^ v) x x' = tau/4 - th + | otherwise = th - tau/4 + sndOf3 (_,b,_) = b + rightTurn (P (x1,y1)) (P (x2, y2)) (P (x3,y3)) = + (x2 - x1)*(y3 - y1) - (y2 - y1)*(x3-x1) < 0 + +-- | The centroid of a set of /n/ points is the sum of vertices +-- divided by /n/. +centroid :: [P2] -> P2 +centroid = pack . uncurry (^/) . (sumV &&& (fromIntegral . length)) . map unpack + +------------------------------------------------------------ +-- Function graphs +------------------------------------------------------------ + +-- | Pieces of a function graph can either be cycles or "hairs". +data GraphPart a = Cycle [a] + | Hair [a] + deriving (Show, Functor) + +orbits :: (Int -> Int) -> Int -> [GraphPart Int] +orbits f n = runST genOrbits + where + f_n i = f i `mod` n + + genOrbits :: ST s [GraphPart Int] + genOrbits = newArray (0,n-1) False >>= genOrbits' + + genOrbits' :: STUArray s Int Bool -> ST s [GraphPart Int] + genOrbits' marks = liftM (concat . catMaybes) (forM [0 .. n-1] (genPart marks)) + + genPart :: STUArray s Int Bool -> Int -> ST s (Maybe [GraphPart Int]) + genPart marks i = do + tr <- markRho i marks + case tr of + [] -> return Nothing + _ -> return . Just . splitParts $ tr + + markRho :: Int -> STUArray s Int Bool -> ST s [Int] + markRho i marks = do + isMarked <- readArray marks i + case isMarked of + True -> return [] + False -> writeArray marks i True >> + liftM (i:) (markRho (f_n i) marks) + + splitParts :: [Int] -> [GraphPart Int] + splitParts tr = hair ++ cyc + where hair | not (null tl) = [Hair $ tl ++ [f_n (last tl)]] + | otherwise = [] + cyc | not (null body) = [Cycle body] + | otherwise = [] + l = last tr + (tl, body) = span (/= f_n l) tr + +-- | Generate a function graph from the given function and labels. +mkGraph :: (Int -> Int) -> [a] -> [GraphPart a] +mkGraph f xs = (map . fmap) (xs!!) $ orbits f (length xs) + +------------------------------------------------------------ +-- Star polygons +------------------------------------------------------------ + +-- | Options for creating \"star\" polygons, where the edges connect +-- possibly non-adjacent vertices. +data StarOpts = StarFun (Int -> Int) + -- ^ Specify the order in which the vertices should be + -- connected by a function that maps each vertex + -- index to the index of the vertex that should come + -- next. Indexing of vertices begins at 0. + + | StarSkip Int + -- ^ Specify a star polygon by a \"skip\". A skip of + -- 1 indicates a normal polygon, where edges go + -- between successive vertices. A skip of 2 means + -- that edges will connect every second vertex, + -- skipping one in between. Generally, a skip of + -- /n/ means that edges will connect every /n/th + -- vertex. + +-- | Create a generalized /star/ /polygon/. The 'StarOpts' are used +-- to determine in which order the given vertices should be +-- connected. The intention is that the second argument of type +-- @[P2]@ could be generated by a call to 'polygon', 'regPoly', or +-- the like, since a list of vertices is 'PathLike'. But of course +-- the list can be generated any way you like. A @'Path' 'R2'@ is +-- returned (instead of any 'PathLike') because the resulting path +-- may have more than one component, for example if the vertices are +-- to be connected in several disjoint cycles. +star :: StarOpts -> [P2] -> Path R2 +star sOpts vs = graphToPath $ mkGraph f vs + where f = case sOpts of + StarFun g -> g + StarSkip k -> (+k) + graphToPath = mconcat . map partToPath + partToPath (Cycle ps) = close $ fromVertices ps + partToPath (Hair ps) = fromVertices ps diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts #-} +{-# LANGUAGE TypeFamilies + , FlexibleContexts + #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Shapes @@ -15,21 +18,28 @@ -- * Miscellaneous hrule, vrule - -- * General polygons - , polygon, polygonVertices - , PolygonOpts(..), PolygonOrientation(..) + -- * Regular polygons - -- * Special polygons - , unitSquare + , regPoly + , eqTriangle , square - , rect - , starPolygon + , pentagon + , hexagon + , septagon + , octagon + , nonagon + , decagon + , hendecagon + , dodecagon - , eqTriangle + -- * Other special polygons + , unitSquare + , rect -- * Other shapes , roundedRect + ) where import Graphics.Rendering.Diagrams @@ -39,14 +49,13 @@ import Diagrams.TwoD.Arc import Diagrams.TwoD.Types import Diagrams.TwoD.Transform +import Diagrams.TwoD.Polygons import Diagrams.Util import Data.Monoid import Data.VectorSpace -import Data.Default - -- | Create a centered horizontal (L-R) line of the given length. hrule :: (PathLike p, V p ~ R2) => Double -> p hrule d = pathLike (P (-d/2,0)) False [Linear (d,0)] @@ -55,56 +64,11 @@ vrule :: (PathLike p, V p ~ R2) => Double -> p vrule d = pathLike (P (0,d/2)) False [Linear (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 closed regular polygon from the given options. -polygon :: (PathLike p, V p ~ R2) => PolygonOpts -> p -polygon opts = pathLike v True (segmentsFromVertices vvs) - where vvs@(v:vs) = polygonVertices opts - --- | Generate the vertices of a regular polygon from the given --- options. -polygonVertices :: PolygonOpts -> [P2] -polygonVertices opts = orient . take n . iterate (rotateBy turn) $ start - where start = translateX 1 origin - turn = fromIntegral (edgeSkip opts) / 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 = rotateBy (turn/2) - | otherwise = id - orientY | even n = rotateBy (turn/2) - | otherwise = id - -- | A sqaure with its center at the origin and sides of length 1, -- oriented parallel to the axes. -unitSquare :: (Transformable p, PathLike p, V p ~ R2) => p -unitSquare = scale (1/sqrt 2) $ polygon with { sides = 4, orientation = OrientToX } +unitSquare :: (PathLike p, V p ~ R2) => p +unitSquare = polygon with { polyType = PolyRegular 4 (sqrt 2 / 2) + , polyOrient = OrientH } -- | A sqaure with its center at the origin and sides of the given -- length, oriented parallel to the axes. @@ -116,41 +80,68 @@ rect :: (PathLike p, Transformable p, V p ~ R2) => Double -> Double -> p rect w h = unitSquare # scaleX w # scaleY h --- | @starPolygon p q@ creates a star polygon, where @p@ indicates the --- number of vertices, and an edge connects every @q@th vertex. -starPolygon :: (PathLike p, Transformable p, V p ~ R2) => Int -> Int -> p -starPolygon p q = polygon def { sides = p, edgeSkip = q } +------------------------------------------------------------ +-- Regular polygons +------------------------------------------------------------ --- | An equilateral triangle, with radius 1 and base parallel to the --- x-axis. -eqTriangle :: (PathLike p, Transformable p, V p ~ R2) => p -eqTriangle = polygon with {sides = 3, orientation = OrientToX} +-- | Create a regular polygon. The first argument is the number of +-- sides, and the second is the /length/ of the sides. (Compare to the +-- 'polygon' function with a 'PolyRegular' option, which produces +-- polygons of a given /radius/). +-- +-- The polygon will be oriented with one edge parallel to the x-axis. +regPoly :: (PathLike p, V p ~ R2) => Int -> Double -> p +regPoly n l = polygon with { polyType = + PolySides + (repeat (1/ fromIntegral n :: CircleFrac)) + (replicate (n-1) l) + , polyOrient = OrientH + } -{- -pentagon :: (Backend b R2, Renderable (Path R2) b) => Diagram b R2 -pentagon = writeMe "pentagon" +-- | An equilateral triangle, with sides of the given length and base parallel +-- to the x-axis. +eqTriangle :: (PathLike p, V p ~ R2) => Double -> p +eqTriangle = regPoly 3 -hexagon :: (Backend b R2, Renderable (Path R2) b) => Diagram b R2 -hexagon = writeMe "hexagon" +-- | A regular pentagon, with sides of the given length and base +-- parallel to the x-axis. +pentagon :: (PathLike p, V p ~ R2) => Double -> p +pentagon = regPoly 5 -septagon :: (Backend b R2, Renderable (Path R2) b) => Diagram b R2 -septagon = writeMe "septagon" +-- | A regular hexagon, with sides of the given length and base +-- parallel to the x-axis. +hexagon :: (PathLike p, V p ~ R2) => Double -> p +hexagon = regPoly 6 -octagon :: (Backend b R2, Renderable (Path R2) b) => Diagram b R2 -octagon = writeMe "octagon" +-- | A regular septagon, with sides of the given length and base +-- parallel to the x-axis. +septagon :: (PathLike p, V p ~ R2) => Double -> p +septagon = regPoly 7 -nonagon :: (Backend b R2, Renderable (Path R2) b) => Diagram b R2 -nonagon = writeMe "nonagon" +-- | A regular octagon, with sides of the given length and base +-- parallel to the x-axis. +octagon :: (PathLike p, V p ~ R2) => Double -> p +octagon = regPoly 8 -decagon :: (Backend b R2, Renderable (Path R2) b) => Diagram b R2 -decagon = writeMe "decagon" +-- | A regular nonagon, with sides of the given length and base +-- parallel to the x-axis. +nonagon :: (PathLike p, V p ~ R2) => Double -> p +nonagon = regPoly 9 --- | 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" --} +-- | A regular decagon, with sides of the given length and base +-- parallel to the x-axis. +decagon :: (PathLike p, V p ~ R2) => Double -> p +decagon = regPoly 10 + +-- | A regular hendecagon, with sides of the given length and base +-- parallel to the x-axis. +hendecagon :: (PathLike p, V p ~ R2) => Double -> p +hendecagon = regPoly 11 + +-- | A regular dodecagon, with sides of the given length and base +-- parallel to the x-axis. +dodecagon :: (PathLike p, V p ~ R2) => Double -> p +dodecagon = regPoly 12 ------------------------------------------------------------ -- Other shapes ------------------------------------------ diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Size.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE FlexibleContexts + , TypeFamilies + #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Size +-- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Utilities for working with sizes of two-dimensional objects. +-- +----------------------------------------------------------------------------- +module Diagrams.TwoD.Size + ( + -- * Size and extent of diagrams in R2 + -- ** Computing sizes + width, height, size2D + , extentX, extentY, center2D + + -- ** Specifying sizes + , SizeSpec2D(..) + ) where + +import Graphics.Rendering.Diagrams +import Diagrams.TwoD.Types + +import Control.Arrow ((***), (&&&)) + +------------------------------------------------------------ +-- Computing diagram sizes +------------------------------------------------------------ + +-- | Compute the width of a boundable object. +width :: (Boundable a, V a ~ R2) => a -> Double +width = negate . uncurry (-) . extentX + +-- | Compute the height of a boundable object. +height :: (Boundable a, V a ~ R2) => a -> Double +height = negate . uncurry (-) . extentY + +-- | Compute the width and height of a boundable object. +size2D :: (Boundable a, V a ~ R2) => a -> (Double, Double) +size2D = width &&& height + +-- | Compute the absolute x-coordinate range of a boundable object in +-- R2, in the form (lo,hi). +extentX :: (Boundable a, V a ~ R2) => a -> (Double, Double) +extentX d = (-f (-1,0), f (1,0)) + where f = appBounds $ getBounds d + +-- | Compute the absolute y-coordinate range of a boundable object in +-- R2, in the form (lo,hi). +extentY :: (Boundable a, V a ~ R2) => a -> (Double, Double) +extentY d = (-f (0,-1), f (0,1)) + where f = appBounds $ getBounds d + +-- | Compute the point at the center (in the x- and y-directions) of a +-- boundable object. +center2D :: (Boundable a, V a ~ R2) => a -> P2 +center2D = P . (mid *** mid) . (extentX &&& extentY) + where mid = (/2) . uncurry (+) + +------------------------------------------------------------ +-- Size specifications +------------------------------------------------------------ + +-- | A specification of a (requested) rectangular size. +data SizeSpec2D = Width Double -- ^ Specify an explicit + -- width. The height should be + -- determined automatically (so + -- as to preserve aspect ratio). + | Height Double -- ^ Specify an explicit + -- height. The width should be + -- determined automatically (so + -- as to preserve aspect ratio) + | Dims Double Double -- ^ An explicit specification + -- of both dimensions. + | Absolute -- ^ Absolute size: use whatever + -- size an object already has; + -- do not rescale. diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -176,7 +176,7 @@ -- | The @FontWeightA@ attribute specifies the weight (normal or bold) -- that should be used for all text within a diagram. Inner -- @FontWeightA@ attributes override outer ones. -newtype FontWeightA = FontWeightA (Last (FontWeight)) +newtype FontWeightA = FontWeightA (Last FontWeight) deriving (Typeable, Semigroup) instance AttributeClass FontWeightA diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -27,6 +27,7 @@ , scaling, scale , scaleToX, scaleToY + , scaleUToX, scaleUToY -- * Translation , translationX, translateX @@ -42,7 +43,8 @@ import Graphics.Rendering.Diagrams import Diagrams.TwoD.Types -import Diagrams.TwoD.Util +import Diagrams.TwoD.Size (width, height) +import Diagrams.TwoD.Vector (direction) import Diagrams.Transform import Diagrams.Util @@ -64,11 +66,11 @@ -- | Rotate by the given angle. Positive angles correspond to -- counterclockwise rotation, negative to clockwise. The angle can -- be expressed using any type which is an instance of 'Angle'. For --- example, @rotate (1/4 :: 'CircleFrac')@, @rotate (pi/2 :: 'Rad')@, and +-- example, @rotate (1\/4 :: 'CircleFrac')@, @rotate (tau\/4 :: 'Rad')@, and -- @rotate (90 :: 'Deg')@ all represent the same transformation, namely, -- a counterclockwise rotation by a right angle. -- --- Note that writing @rotate (1/4)@, with no type annotation, will +-- Note that writing @rotate (1\/4)@, with no type annotation, will -- yield an error since GHC cannot figure out which sort of angle -- you want to use. In this common situation you can use -- 'rotateBy', which is specialized to take a 'CircleFrac' argument. @@ -77,7 +79,7 @@ -- | A synonym for 'rotate', specialized to only work with -- @CircleFrac@ arguments; it can be more convenient to write --- @rotateBy (1/4)@ than @'rotate' (1/4 :: 'CircleFrac')@. +-- @rotateBy (1\/4)@ than @'rotate' (1\/4 :: 'CircleFrac')@. rotateBy :: (Transformable t, V t ~ R2) => CircleFrac -> t -> t rotateBy = transform . rotation @@ -131,6 +133,19 @@ scaleToY :: (Boundable t, Transformable t, V t ~ R2) => Double -> t -> t scaleToY h d = scaleY (h / height d) d +-- | @scaleUToX w@ scales a diagram /uniformly/ by whatever factor +-- required to make its width @w@. @scaleUToX@ should not be +-- applied to diagrams with a width of 0, such as 'vrule'. +scaleUToX :: (Boundable t, Transformable t, V t ~ R2) => Double -> t -> t +scaleUToX w d = scale (w / width d) d + +-- | @scaleUToY h@ scales a diagram in the y (vertical) direction by +-- whatever factor required to make its height @h@. @scaleUToY@ +-- should not be applied to diagrams with a width of 0, such as +-- 'hrule'. +scaleUToY :: (Boundable t, Transformable t, V t ~ R2) => Double -> t -> t +scaleUToY h d = scale (h / height d) d + -- Translation --------------------------------------------- -- | Construct a transformation which translates by the given distance @@ -178,8 +193,9 @@ -- | @reflectionAbout p v@ is a reflection in the line determined by -- the point @p@ and vector @v@. reflectionAbout :: P2 -> R2 -> T2 -reflectionAbout p v = conjugate (rotation (-direction v) <> translation (origin .-. p)) - reflectionY +reflectionAbout p v = + conjugate (rotation (-direction v :: Rad) <> translation (origin .-. p)) + reflectionY -- | @reflectAbout p v@ reflects a diagram in the line determined by -- the point @p@ and the vector @v@. diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies , TypeSynonymInstances + , FlexibleInstances , GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -21,7 +22,6 @@ , T2 -- * Angles - , tau , Angle(..) , CircleFrac(..), Rad(..), Deg(..) , fullCircle, convertAngle @@ -29,6 +29,8 @@ import Graphics.Rendering.Diagrams +import Math.Tau + ------------------------------------------------------------ -- 2D Euclidean space @@ -48,11 +50,6 @@ ------------------------------------------------------------ -- Angles - --- | The circle constant, i.e. the ratio of a circle's circumference --- to its radius. See . -tau :: Floating a => a -tau = 2*pi -- | Newtype wrapper used to represent angles as fractions of a -- circle. For example, 1/3 = tau/3 radians = 120 degrees. diff --git a/src/Diagrams/TwoD/Util.hs b/src/Diagrams/TwoD/Util.hs deleted file mode 100644 --- a/src/Diagrams/TwoD/Util.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE FlexibleContexts - , TypeFamilies - #-} ------------------------------------------------------------------------------ --- | --- 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, unit_X, unit_Y - , direction - - -- * Size and extent of diagrams in R2 - -- ** Computing sizes - , width, height, size2D - , extentX, extentY, center2D - - -- ** Specifying sizes - , SizeSpec2D(..) - ) where - -import Graphics.Rendering.Diagrams -import Diagrams.TwoD.Types - -import Control.Arrow ((***), (&&&)) - --- | Compute the width of a diagram. -width :: (Boundable a, V a ~ R2) => a -> Double -width = negate . uncurry (-) . extentX - --- | Compute the height of a diagram. -height :: (Boundable a, V a ~ R2) => a -> Double -height = negate . uncurry (-) . extentY - --- | Compute the width and height of a diagram. -size2D :: (Boundable a, V a ~ R2) => a -> (Double, Double) -size2D = width &&& height - --- | Compute the absolute x-coordinate range of a diagram in R2, in --- the form (lo,hi). -extentX :: (Boundable a, V a ~ R2) => a -> (Double, Double) -extentX d = (-f (-1,0), f (1,0)) - where f = appBounds $ getBounds d - --- | Compute the absolute y-coordinate range of a diagram in R2, in --- the form (lo,hi). -extentY :: (Boundable a, V a ~ R2) => a -> (Double, Double) -extentY d = (-f (0,-1), f (0,1)) - where f = appBounds $ getBounds d - --- | Compute the point at the center (in the x- and y-directions) of a --- diagram. -center2D :: (Boundable a, V a ~ R2) => a -> P2 -center2D = P . (mid *** mid) . (extentX &&& extentY) - where mid = (/2) . uncurry (+) - --- | The unit vector in the positive X direction. -unitX :: R2 -unitX = (1,0) - --- | The unit vector in the positive Y direction. -unitY :: R2 -unitY = (0,1) - --- | The unit vector in the negative X direction. -unit_X :: R2 -unit_X = (-1,0) - --- | The unit vector in the negative Y direction. -unit_Y :: R2 -unit_Y = (0,-1) - --- | Compute the direction of a vector, measured counterclockwise from --- the positive x-axis as a fraction of a full turn. The zero --- vector is arbitrarily assigned the direction 0. -direction :: R2 -> CircleFrac -direction (x,y) = toCircleFrac . Rad $ atan2 y x - ------------------------------------------------------------- --- Size specifications ------------------------------------------------------------- - --- | A specification of a (requested) rectangular size. -data SizeSpec2D = Width Double -- ^ Specify an explicit - -- width. The height should be - -- determined automatically (so - -- as to preserve aspect ratio). - | Height Double -- ^ Specify an explicit - -- height. The width should be - -- determined automatically (so - -- as to preserve aspect ratio) - | Dims Double Double -- ^ An explicit specification - -- of both dimensions. - | Absolute -- ^ Absolute size: use whatever - -- size an object already has; - -- do not rescale. diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Vector.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleContexts + , TypeFamilies + #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Vector +-- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Two-dimensional vectors. +-- +----------------------------------------------------------------------------- +module Diagrams.TwoD.Vector + ( -- * Special 2D vectors + unitX, unitY, unit_X, unit_Y + + -- * Converting between vectors and angles + , direction, fromDirection, e + ) where + +import Diagrams.TwoD.Types + +-- | The unit vector in the positive X direction. +unitX :: R2 +unitX = (1,0) + +-- | The unit vector in the positive Y direction. +unitY :: R2 +unitY = (0,1) + +-- | The unit vector in the negative X direction. +unit_X :: R2 +unit_X = (-1,0) + +-- | The unit vector in the negative Y direction. +unit_Y :: R2 +unit_Y = (0,-1) + +-- | Compute the direction of a vector, measured counterclockwise from +-- the positive x-axis as a fraction of a full turn. The zero +-- vector is arbitrarily assigned the direction 0. +direction :: Angle a => R2 -> a +direction (x,y) = convertAngle . Rad $ atan2 y x + +-- | Convert an angle into a unit vector pointing in that direction. +fromDirection :: Angle a => a -> R2 +fromDirection a = (cos a', sin a') + where Rad a' = convertAngle a + +-- | A convenient synonym for 'fromDirection'. +e :: Angle a => a -> R2 +e = fromDirection