diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,85 @@ +0.7 (9 August 2013) +------------------- + +* **New features** + + - New module `Diagrams.TwoD.Curvature`, for computing the + curvature of 2D segments at any given point. + - New module `Diagrams.Offset`, containing an `offsetSegment` + function that builds a trail a fixed distance from the original + segment. This is a precursor to planned functions `offsetTrail` + and `offsetPath`. + - New function `Diagrams.TwoD.Transform.onBasis`, for extracting a + matrix representation of a 2D transformation + - New functions `extrudeEnvelope` and `intrudeEnvelope`, for + extending or shrinking an envelope only in a certain direction. + - Generalize the `Color` class to absolute colors. + This addresses concerns raised in issue #66 by letting the backend + choose which color space to render `Color` instances to. Functions are + provided for backwards compatibility with the old semantics. + - New function `scaleInvPrim` for creating a diagram from a single + scale-invariant primitive. + - New module `Diagrams.Parametric`, containing a collection of + classes abstracting over "parametric" things: `Parametric`, + `DomainBounds`, `EndValues`, `Sectionable`, and `HasArcLength`, + with instances for segments, trails, and related things. + - A big refactoring of segments and trails: + - Segments can now be either "closed" or "open". + - There are now two types of trails: "lines" (which travel + from point A to point B) or "loops" (closed curves which end + where they started). `Trail` is now a wrapper type which can + contain both loops and lines. + - There is a new `Located` wrapper type for adding locations to + translation-invariant things. `Path`s now consist of a + collection of `Located Trail`s. + - The `PathLike` class is now renamed to `TrailLike`; the + `trailLike` function takes a `Located Trail` as input. + - New convenience functions `boundaryFrom` and `boundaryFromMay`, + for computing boundaries of subdiagrams. + - Re-export from `diagrams-lib` a lot of things defined in + `diagrams-core`, to make them easier for users to find. Several + new modules have been created as a result: `Diagrams.Query`, + `Diagrams.Envelope`, `Diagrams.Trace`, and `Diagrams.Names`. + - Export the `centroid` function from `Diagrams.Prelude`. + - `triangle` is now a synonym for `eqTriangle`. + +* **New instances** + + - `IsPrim` instances for `Path`, `Ellipsoid`, `Image`, `Text`, and + `ScaleInv` + - `Eq`, `Ord`, and `Show` instances for `SizeSpec2D` + +* **API changes** + + - `CircleFrac` has been renamed `Turn` (though `CircleFrac` is + retained as a deprecated synonym). + - `Diagrams.Coordinates` is no longer exported from + `Diagrams.Prelude`. This is for compatibility with `lens`, as `(&)` + is a rather important lens operator and clashes with + `Diagrams.Coordinates`. Users who want the `Coordinates` stuff can import + `Diagrams.Coordinates` explicitly. + +* **Dependency/version changes** + + - allow `base-4.7` + - upgrade to `monoid-extras-0.3` + - depend on `data-default-class` instead of `data-default` + - Tested with GHC 7.7. + +* **Bug fixes** + + - Added a special case that was a not handled properly by the + quadratic solver, resulting in bogus envelopes in certain cases + (#88). + - Import only `Data.NumInstances.Tuple` instead of + `Data.NumInstances`. Previously, `Diagrams.Prelude` exported + `Eq`, `Show`, and `Num` instances for functions and tuples; now + it only exports tuple instances. Users wishing to use + `Diagrams.CubicSpline` with a vector space built over functions (!?) + can import `Data.NumInstances.Function` themselves. (#48) + - Do scaling on a `Path` *before* constructing a `TrailLike` in + `rect` (#43) + 0.6.0.3 (4 May 2013) -------------------- @@ -295,4 +377,3 @@ ---------------- * initial preview release - diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,8 @@ -Copyright (c) 2011-2012 diagrams-lib team: +Copyright (c) 2011-2013 diagrams-lib team: + Daniel Bergey + Daniil Frumin + Niklas Haas Peter Hall Claude Heiland-Allen Deepak Jois diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,29 @@ -#!/usr/bin/env runhaskell -import Distribution.Simple -main = defaultMain +import Data.List (isSuffixOf) +import Distribution.Simple +import Distribution.Simple.Setup (Flag (..), HaddockFlags, + haddockDistPref) +import Distribution.Simple.Utils (copyFiles) +import Distribution.Text (display) +import Distribution.Verbosity (normal) +import System.Directory (getDirectoryContents) +import System.FilePath (()) + +-- Ugly hack, logic copied from Distribution.Simple.Haddock +haddockOutputDir :: Package pkg => HaddockFlags -> pkg -> FilePath +haddockOutputDir flags pkg = destDir + where + baseDir = case haddockDistPref flags of + NoFlag -> "." + Flag x -> x + destDir = baseDir "doc" "html" display (packageName pkg) + +diagramsDir = "diagrams" + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { postHaddock = \args flags pkg lbi -> do + dias <- filter ("svg" `isSuffixOf`) `fmap` getDirectoryContents diagramsDir + copyFiles normal (haddockOutputDir flags pkg) + (map (\d -> ("", diagramsDir d)) dias) + postHaddock simpleUserHooks args flags pkg lbi + } 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.6.0.3 +Version: 0.7 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 @@ -15,10 +15,10 @@ Maintainer: diagrams-discuss@googlegroups.com Bug-reports: http://github.com/diagrams/diagrams-lib/issues Category: Graphics -Build-type: Simple -Cabal-version: >=1.6 -Extra-source-files: CHANGES.markdown, README.markdown -Tested-with: GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.2, GHC == 7.6.1 +Build-type: Custom +Cabal-version: >=1.10 +Extra-source-files: CHANGES.markdown, README.markdown, diagrams/*.svg +Tested-with: GHC == 7.4.2, GHC == 7.6.1 Source-repository head type: git location: http://github.com/diagrams/diagrams-lib.git @@ -30,13 +30,21 @@ Diagrams.Coordinates, Diagrams.Attributes, Diagrams.Points, + Diagrams.Located, + Diagrams.Parametric, Diagrams.Segment, + Diagrams.Trail, + Diagrams.TrailLike, Diagrams.Path, Diagrams.CubicSpline, Diagrams.CubicSpline.Internal, Diagrams.Solve, Diagrams.Transform, Diagrams.BoundingBox, + Diagrams.Names, + Diagrams.Envelope, + Diagrams.Trace, + Diagrams.Query, Diagrams.TwoD, Diagrams.TwoD.Types, Diagrams.TwoD.Align, @@ -45,6 +53,8 @@ Diagrams.TwoD.Ellipse, Diagrams.TwoD.Arc, Diagrams.TwoD.Segment, + Diagrams.TwoD.Curvature, + Diagrams.TwoD.Offset, Diagrams.TwoD.Path, Diagrams.TwoD.Polygons, Diagrams.TwoD.Shapes, @@ -60,17 +70,20 @@ Diagrams.Animation.Active, Diagrams.Util, Diagrams.Backend.Show - Build-depends: base >= 4.2 && < 4.7, + Build-depends: base >= 4.2 && < 4.8, containers >= 0.3 && < 0.6, array >= 0.3 && < 0.5, semigroups >= 0.3.4 && < 0.10, - monoid-extras >= 0.2.2 && < 0.3, - diagrams-core >= 0.6 && < 0.7, + monoid-extras >= 0.3 && < 0.4, + diagrams-core >= 0.7 && < 0.8, active >= 0.1 && < 0.2, vector-space >= 0.7.7 && < 0.9, - NumInstances >= 1.0 && < 1.4, + NumInstances >= 1.2 && < 1.4, colour >= 2.3.2 && < 2.4, - data-default >= 0.2 && < 0.6, + data-default-class < 0.1, pretty >= 1.0.1.2 && < 1.2, - newtype >= 0.2 && < 0.3 + newtype >= 0.2 && < 0.3, + fingertree >= 0.1 && < 0.2, + intervals >= 0.2.2 && < 0.3 Hs-source-dirs: src + default-language: Haskell2010 diff --git a/diagrams/besideEx.svg b/diagrams/besideEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/besideEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/closeLineEx.svg b/diagrams/closeLineEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/closeLineEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/cubicOffsetExample.svg b/diagrams/cubicOffsetExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/cubicOffsetExample.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/cubicSplineEx.svg b/diagrams/cubicSplineEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/cubicSplineEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/decagonEx.svg b/diagrams/decagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/decagonEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/diagramA.svg b/diagrams/diagramA.svg new file mode 100644 --- /dev/null +++ b/diagrams/diagramA.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/diagramNeg.svg b/diagrams/diagramNeg.svg new file mode 100644 --- /dev/null +++ b/diagrams/diagramNeg.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/diagramPos.svg b/diagrams/diagramPos.svg new file mode 100644 --- /dev/null +++ b/diagrams/diagramPos.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/diagramZero.svg b/diagrams/diagramZero.svg new file mode 100644 --- /dev/null +++ b/diagrams/diagramZero.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/dodecagonEx.svg b/diagrams/dodecagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/dodecagonEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/glueLineEx.svg b/diagrams/glueLineEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/glueLineEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/hendecagonEx.svg b/diagrams/hendecagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/hendecagonEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/hexagonEx.svg b/diagrams/hexagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/hexagonEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/hruleEx.svg b/diagrams/hruleEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/hruleEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/lineFromOffsetsEx.svg b/diagrams/lineFromOffsetsEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/lineFromOffsetsEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/lineFromVerticesEx.svg b/diagrams/lineFromVerticesEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/lineFromVerticesEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/nonagonEx.svg b/diagrams/nonagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/nonagonEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/octagonEx.svg b/diagrams/octagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/octagonEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/pentagonEx.svg b/diagrams/pentagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/pentagonEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/rectEx.svg b/diagrams/rectEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/rectEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/roundedRectEx.svg b/diagrams/roundedRectEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/roundedRectEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/septagonEx.svg b/diagrams/septagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/septagonEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/squareEx.svg b/diagrams/squareEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/squareEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/trailOffsetEx.svg b/diagrams/trailOffsetEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/trailOffsetEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/triangleEx.svg b/diagrams/triangleEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/triangleEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/unitSquareEx.svg b/diagrams/unitSquareEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/unitSquareEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/vruleEx.svg b/diagrams/vruleEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/vruleEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/src/Diagrams/Align.hs b/src/Diagrams/Align.hs --- a/src/Diagrams/Align.hs +++ b/src/Diagrams/Align.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE TypeFamilies - , FlexibleContexts - , UndecidableInstances - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Align --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -31,13 +30,13 @@ ) where -import Diagrams.Core +import Diagrams.Core -import Data.VectorSpace -import Data.AffineSpace (alerp) +import Data.AffineSpace (alerp) +import Data.VectorSpace -import qualified Data.Set as S -import qualified Data.Map as M +import qualified Data.Map as M +import qualified Data.Set as S -- | Class of things which can be aligned. class Alignable a where diff --git a/src/Diagrams/Animation.hs b/src/Diagrams/Animation.hs --- a/src/Diagrams/Animation.hs +++ b/src/Diagrams/Animation.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE TypeFamilies - , FlexibleContexts - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Animation @@ -29,21 +29,21 @@ ) where -import Diagrams.Core +import Diagrams.Core -import Diagrams.Combinators -import Diagrams.Animation.Active () -import Diagrams.BoundingBox -import Diagrams.TwoD.Shapes -import Diagrams.TwoD.Types -import Diagrams.Path +import Diagrams.Animation.Active () +import Diagrams.BoundingBox +import Diagrams.Combinators +import Diagrams.TrailLike +import Diagrams.TwoD.Shapes +import Diagrams.TwoD.Types -import Data.Active -import Data.Semigroup +import Data.Active +import Data.Semigroup -import Control.Applicative ((<$>)) -import Data.Foldable (foldMap) -import Data.VectorSpace +import Control.Applicative ((<$>)) +import Data.Foldable (foldMap) +import Data.VectorSpace -- | A value of type @QAnimation b v m@ is an animation (a -- time-varying diagram with start and end times) that can be @@ -109,16 +109,16 @@ -- -- Uses 30 samples per time unit by default; to adjust this number -- see 'animRect''. -animRect :: (PathLike p, Enveloped p, Transformable p, V p ~ R2) - => QAnimation b R2 m -> p +animRect :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ R2) + => QAnimation b R2 m -> t animRect = animRect' 30 -- | Like 'animRect', but with an adjustible sample rate. The first -- parameter is the number of samples per time unit to use. Lower -- rates will be faster but less accurate; higher rates are more -- accurate but slower. -animRect' :: (PathLike p, Enveloped p, Transformable p, V p ~ R2) - => Rational -> QAnimation b R2 m -> p +animRect' :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ R2) + => Rational -> QAnimation b R2 m -> t animRect' r anim | null results = rect 1 1 | otherwise = boxFit (foldMap boundingBox results) (rect 1 1) diff --git a/src/Diagrams/Animation/Active.hs b/src/Diagrams/Animation/Active.hs --- a/src/Diagrams/Animation/Active.hs +++ b/src/Diagrams/Animation/Active.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE TypeFamilies - #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -17,8 +16,8 @@ -- * 'HasOrigin', 'Transformable', and 'HasStyle' instances for -- 'Active' which all work pointwise. -- --- * A 'PathLike' instance for @'Active' p@ where @p@ is also --- 'PathLike', which simply lifts a pathlike thing to a constant +-- * A 'TrailLike' instance for @'Active' p@ where @p@ is also +-- 'TrailLike', which simply lifts a pathlike thing to a constant -- active value. -- -- * A 'Juxtaposable' instance for @'Active' a@ where @a@ is also @@ -38,13 +37,14 @@ module Diagrams.Animation.Active where -import Diagrams.Core -import Control.Applicative ((<$>), pure) +import Control.Applicative (pure, (<$>)) -import Diagrams.Align -import Diagrams.Path +import Diagrams.Align +import Diagrams.Core +import Diagrams.Path +import Diagrams.TrailLike -import Data.Active +import Data.Active type instance V (Active a) = V a @@ -63,8 +63,8 @@ instance HasStyle a => HasStyle (Active a) where applyStyle = fmap . applyStyle -instance PathLike p => PathLike (Active p) where - pathLike st cl segs = pure (pathLike st cl segs) +instance TrailLike t => TrailLike (Active t) where + trailLike = pure . trailLike -- | An active value can be juxtaposed against another by doing the -- juxtaposition pointwise over time. The era of @juxtapose v a1 diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -37,6 +37,9 @@ -- ** Opacity , Opacity, getOpacity, opacity + -- ** Converting colors + , toRGBAUsingSpace, colorToSRGBA, colorToRGBA + -- * Lines -- ** Width , LineWidth, getLineWidth, lineWidth, lw @@ -55,7 +58,8 @@ import Diagrams.Core import Data.Colour -import qualified Data.Colour.SRGB as RGB +import Data.Colour.RGBSpace +import Data.Colour.SRGB (sRGBSpace) import Data.Typeable @@ -79,9 +83,8 @@ -- 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) + -- | Convert a color to its standard representation, AlphaColour + toAlphaColour :: c -> AlphaColour Double -- | An existential wrapper for instances of the 'Color' class. data SomeColor = forall c. Color c => SomeColor c @@ -152,29 +155,37 @@ 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' + toAlphaColour = opaque . colourConvert 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' + toAlphaColour = alphaColourConvert instance Color SomeColor where - colorToRGBA (SomeColor c) = colorToRGBA c + toAlphaColour (SomeColor c) = toAlphaColour c instance Color LineColor where - colorToRGBA (LineColor (Last c)) = colorToRGBA c + toAlphaColour (LineColor (Last c)) = toAlphaColour c instance Color FillColor where - colorToRGBA (FillColor c) = colorToRGBA . getLast . getRecommend $ c + toAlphaColour (FillColor c) = toAlphaColour . getLast . getRecommend $ c + +-- | Convert to an RGB space while preserving the alpha channel. +toRGBAUsingSpace :: Color c => RGBSpace Double -> c + -> (Double, Double, Double, Double) +toRGBAUsingSpace s col = (r,g,b,a) + where c' = toAlphaColour col + c = toRGBUsingSpace s (alphaToColour c') + a = alphaChannel c' + r = channelRed c + g = channelGreen c + b = channelBlue c + +-- | Convert to sRGBA. +colorToSRGBA, colorToRGBA :: Color c => c -> (Double, Double, Double, Double) +colorToSRGBA = toRGBAUsingSpace sRGBSpace + +colorToRGBA = colorToSRGBA +{-# DEPRECATED colorToRGBA "Renamed to colorToSRGBA." #-} alphaToColour :: (Floating a, Ord a, Fractional a) => AlphaColour a -> Colour a alphaToColour ac | alphaChannel ac == 0 = ac `over` black diff --git a/src/Diagrams/Backend/Show.hs b/src/Diagrams/Backend/Show.hs --- a/src/Diagrams/Backend/Show.hs +++ b/src/Diagrams/Backend/Show.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE FlexibleInstances - , FlexibleContexts - , MultiParamTypeClasses - , ScopedTypeVariables - , TypeSynonymInstances - , TypeFamilies - , GeneralizedNewtypeDeriving - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Backend.Show @@ -18,14 +17,16 @@ ----------------------------------------------------------------------------- module Diagrams.Backend.Show where -import Diagrams.Prelude +import Diagrams.Core.Transform (onBasis) +import Diagrams.Prelude +import Diagrams.Trail -import Data.Basis +import Data.Basis -import Text.PrettyPrint (Doc, empty, ($+$), parens, hsep) -import qualified Text.PrettyPrint as PP +import Text.PrettyPrint (Doc, empty, hsep, parens, ($+$)) +import qualified Text.PrettyPrint as PP -import Data.List (transpose) +import Data.List (transpose) -- | Token for identifying this backend. data ShowBackend = ShowBackend @@ -46,14 +47,8 @@ renderTransf :: forall v. (Num (Scalar v), HasLinearMap v, Show (Scalar 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 + where vmat :: [v] + (vmat, _) = onBasis t mat :: [[Scalar v]] mat = map decompV vmat -- mat' :: [[Scalar v]] @@ -64,11 +59,11 @@ renderMat = PP.vcat . map renderRow . transpose where renderRow = parens . hsep . map (PP.text . show) -instance (Show v, HasLinearMap v) => Renderable (Segment v) ShowBackend where +instance (Show v, HasLinearMap v) => Renderable (Segment o v) ShowBackend where render _ s = SR $ PP.text (show s) -instance (Show v, HasLinearMap v) => Renderable (Trail v) ShowBackend where +instance (Show v, OrderedField (Scalar v), InnerSpace v, HasLinearMap v) => Renderable (Trail v) ShowBackend where render _ t = SR $ PP.text (show t) -instance (Ord v, Show v, HasLinearMap v) => Renderable (Path v) ShowBackend where +instance (Show v, OrderedField (Scalar v), InnerSpace v, HasLinearMap v) => Renderable (Path v) ShowBackend where render _ p = SR $ PP.text (show p) diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE TypeFamilies - , FlexibleContexts - , UndecidableInstances - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Combinators @@ -22,28 +22,30 @@ , extrudeEnvelope, intrudeEnvelope -- * Binary operations + , atop , beneath , beside -- * n-ary operations , appends - , position, decorateTrail, decoratePath + , position, decorateTrail, decorateLocatedTrail, decoratePath , cat, cat', CatOpts(..), CatMethod(..) ) where -import Diagrams.Core - -import Diagrams.Segment (Segment(..)) -import Diagrams.Path -import Diagrams.Util - -import Data.AdditiveGroup -import Data.VectorSpace - -import Data.Semigroup +import Data.AdditiveGroup +import Data.AffineSpace ((.+^)) +import Data.Default.Class +import Data.Semigroup +import Data.VectorSpace -import Data.Default +import Diagrams.Core +import Diagrams.Located +import Diagrams.Path +import Diagrams.Segment (Segment (..), straight) +import Diagrams.Trail (Trail, trailVertices) +import Diagrams.TrailLike (fromOffsets) +import Diagrams.Util ------------------------------------------------------------ -- Working with envelopes @@ -91,7 +93,7 @@ ) => v -> QDiagram b v m strut v = mkQD nullPrim env mempty mempty mempty - where env = translate ((-0.5) *^ v) . getEnvelope $ Linear v + where env = translate ((-0.5) *^ v) . getEnvelope $ straight v -- note we can't use 'phantom' here because it tries to construct a -- trace as well, and segments do not have a trace in general (only -- in 2D; see Diagrams.TwoD.Segment). This is a good reason to have @@ -161,13 +163,23 @@ -- from the local origin of the first object to the local origin of -- the second object, at a distance so that their envelopes are just -- tangent. The local origin of the new, combined object is the --- local origin of the first object. +-- local origin of the first object (unless the first object is the +-- identity element, in which case the second object is returned +-- unchanged). -- +-- <> +-- +-- > besideEx = beside (r2 (20,30)) +-- > (circle 1 # fc orange) +-- > (circle 1.5 # fc purple) +-- > # showOrigin +-- > # centerXY # pad 1.1 +-- -- Note that @beside v@ is associative, so objects under @beside v@ --- form a semigroup for any given vector @v@. However, they do --- /not/ form a monoid, since there is no identity element. 'mempty' --- is a right identity (@beside v d1 mempty === d1@) but not a left --- identity (@beside v mempty d1 === d1 # align (negateV v)@). +-- form a semigroup for any given vector @v@. In fact, they also +-- form a monoid: 'mempty' is clearly a right identity (@beside v d1 +-- mempty === d1@), and there should also be a special case to make +-- it a left identity, as described above. -- -- In older versions of diagrams, @beside@ put the local origin of -- the result at the point of tangency between the two inputs. That @@ -183,8 +195,6 @@ beside :: (Juxtaposable a, Semigroup a) => V a -> a -> a -> a beside v d1 d2 = d1 <> juxtapose v d1 d2 --- XXX add picture to above documentation? - ------------------------------------------------------------ -- Combining multiple objects ------------------------------------------------------------ @@ -208,15 +218,26 @@ -- 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) +decorateTrail :: (InnerSpace (V a), OrderedField (Scalar (V a)), HasOrigin a, Monoid' a) + => Trail (V a) -> [a] -> a +decorateTrail = decorateLocatedTrail . (`at` origin) -- | Combine a list of diagrams (or paths) by using them to +-- \"decorate\" a concretely located 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. +decorateLocatedTrail :: (InnerSpace (V a), OrderedField (Scalar (V a)), HasOrigin a, Monoid' a) + => Located (Trail (V a)) -> [a] -> a +decorateLocatedTrail t = position . zip (trailVertices 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 :: (InnerSpace (V a), OrderedField (Scalar (V a)), HasOrigin a, Monoid' a) + => Path (V a) -> [a] -> a decoratePath p = position . zip (concat $ pathVertices p) -- | Methods for concatenating diagrams. @@ -277,7 +298,7 @@ -- See also 'cat'', which takes an extra options record allowing -- certain aspects of the operation to be tweaked. cat :: ( Juxtaposable a, Monoid' a, HasOrigin a - , InnerSpace (V a), Floating (Scalar (V a)) + , InnerSpace (V a), OrderedField (Scalar (V a)) ) => V a -> [a] -> a cat v = cat' v def @@ -300,7 +321,7 @@ -- (distributing with a separation of 0 is the same as -- superimposing). cat' :: ( Juxtaposable a, Monoid' a, HasOrigin a - , InnerSpace (V a), Floating (Scalar (V a)) + , InnerSpace (V a), OrderedField (Scalar (V a)) ) => V a -> CatOpts (V a) -> [a] -> a cat' v (CatOpts { catMethod = Cat, sep = s }) = foldB comb mempty @@ -308,5 +329,4 @@ vs = s *^ normalized (negateV v) cat' v (CatOpts { catMethod = Distrib, sep = s }) = - decorateTrail . fromOffsets . repeat $ s *^ normalized v - -- infinite trail, no problem for Haskell =D + position . zip (iterate (.+^ (s *^ normalized v)) origin) diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | @@ -10,6 +10,11 @@ -- Nice syntax for constructing and pattern-matching on literal -- points and vectors. -- +-- NOTE: to avoid clashing with the '(&)' operator from the @lens@ +-- package, this module is not re-exported by "Diagrams.Prelude". To +-- make use of the contents of this module, you must explicitly import +-- it. +-- ----------------------------------------------------------------------------- module Diagrams.Coordinates @@ -30,8 +35,10 @@ -- 'coords'. A common pattern is to use 'coords' in conjunction -- with the @ViewPatterns@ extension, like so: -- --- > foo :: Vector3 -> ... --- > foo (coords -> x :& y :& z) = ... +-- @ +-- foo :: Vector3 -> ... +-- foo (coords -> x :& y :& z) = ... +-- @ class Coordinates c where -- | The type of the final coordinate. @@ -48,8 +55,10 @@ -- less dimension (which is perhaps itself recursively constructed -- using @(&)@) and a final coordinate. For example, -- - -- > 2 & 3 :: P2 - -- > 3 & 5 & 6 :: R3 + -- @ + -- 2 & 3 :: P2 + -- 3 & 5 & 6 :: R3 + -- @ -- -- Note that @&@ is left-associative. (&) :: PrevDim c -> FinalCoord c -> c diff --git a/src/Diagrams/CubicSpline.hs b/src/Diagrams/CubicSpline.hs --- a/src/Diagrams/CubicSpline.hs +++ b/src/Diagrams/CubicSpline.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE TypeFamilies - , FlexibleContexts - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- -- | @@ -13,8 +12,9 @@ -- passing through a given sequence of points. This module provides -- the 'cubicSpline' method, which can be used to create closed or -- open cubic splines from a list of points. For access to the --- internals of the spline generation algorithm, see --- "Diagrams.CubicSpline.Internal". +-- internals of the spline generation algorithm (including in +-- particular a solver for cyclic tridiagonal systems of linear +-- equations), see "Diagrams.CubicSpline.Internal". -- ----------------------------------------------------------------------------- module Diagrams.CubicSpline @@ -23,27 +23,46 @@ cubicSpline ) where -import Diagrams.CubicSpline.Internal - -import Diagrams.Core -import Diagrams.Core.Points - -import Diagrams.Segment -import Diagrams.Path +import Diagrams.Core +import Diagrams.Core.Points +import Diagrams.CubicSpline.Internal +import Diagrams.Located (at) +import Diagrams.Located +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail +import Diagrams.TrailLike (TrailLike (..)) -import Data.NumInstances () -- for e.g. the Fractional (Double, Double) instance +-- for e.g. the Fractional (Double, Double) instance +import Data.NumInstances.Tuple () -import Control.Newtype -import Data.Semigroup +import Control.Newtype +import Data.Semigroup +import Data.VectorSpace -- | 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 +-- +-- <> +-- +-- > pts = map p2 [(0,0), (2,3), (5,-2), (-4,1), (0,3)] +-- > dot = circle 0.2 # fc blue # lw 0 +-- > mkPath closed = position (zip pts (repeat dot)) +-- > <> cubicSpline closed pts # lw 0.05 +-- > cubicSplineEx = (mkPath False ||| strutX 2 ||| mkPath True) +-- > # centerXY # pad 1.1 +-- +-- For more information, see . +cubicSpline :: (TrailLike t, Fractional (V t)) => Bool -> [Point (V t)] -> t +cubicSpline c [] = trailLike . closeIf c $ emptyLine `at` origin +cubicSpline c ps = flattenBeziers . map f . solveCubicSplineCoefficients c . 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) + flattenBeziers bs@((b:_):_) + = trailLike . closeIf c $ lineFromSegments (map bez bs) `at` P b bez [a,b,c,d] = bezier3 (b - a) (c - a) (d - a) + +closeIf :: (InnerSpace v, OrderedField (Scalar v)) + => Bool -> Located (Trail' Line v) -> Located (Trail v) +closeIf c = mapLoc (if c then wrapLoop . glueLine else wrapLine) diff --git a/src/Diagrams/Envelope.hs b/src/Diagrams/Envelope.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Envelope.hs @@ -0,0 +1,30 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Envelope +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- \"Envelopes\", aka functional bounding regions. See +-- "Diagrams.Core.Envelope" for internal implementation details. +-- +----------------------------------------------------------------------------- + +module Diagrams.Envelope + ( -- * Types + Envelope, Enveloped + + -- * Diagram envelopes + , envelope, setEnvelope, withEnvelope, phantom + , pad, extrudeEnvelope, intrudeEnvelope + + -- * Querying envelopes + , envelopeVMay, envelopeV, envelopePMay, envelopeP + , diameter, radius + + ) where + +import Diagrams.Core (envelope, setEnvelope) +import Diagrams.Core.Envelope + +import Diagrams.Combinators diff --git a/src/Diagrams/Located.hs b/src/Diagrams/Located.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Located.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Located +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- \"Located\" things, /i.e./ things with a concrete location: +-- intuitively, @Located a ~ (a, Point)@. Wrapping a translationally +-- invariant thing (/e.g./ a 'Segment' or 'Trail') in @Located@ pins +-- it down to a particular location and makes it no longer +-- translationally invariant. +-- +----------------------------------------------------------------------------- + +module Diagrams.Located + ( Located + , at, viewLoc, unLoc, loc, mapLoc + ) + where + +import Data.AffineSpace +import Data.VectorSpace + +import Diagrams.Core +import Diagrams.Core.Points +import Diagrams.Core.Transform +import Diagrams.Parametric + -- for GHC 7.4 type family bug + +-- | \"Located\" things, /i.e./ things with a concrete location: +-- intuitively, @Located a ~ (Point, a)@. Wrapping a translationally +-- invariant thing (/e.g./ a 'Segment' or 'Trail') in 'Located' pins +-- it down to a particular location and makes it no longer +-- translationally invariant. +-- +-- @Located@ is intentionally abstract. To construct @Located@ +-- values, use 'at'. To destruct, use 'viewLoc', 'unLoc', or 'loc'. +-- To map, use 'mapLoc'. +-- +-- Much of the utility of having a concrete type for the @Located@ +-- concept lies in the type class instances we can give it. The +-- 'HasOrigin', 'Transformable', 'Enveloped', 'Traced', and +-- 'TrailLike' instances are particularly useful; see the documented +-- instances below for more information. +data Located a = Loc { loc :: Point (V a) -- ^ Project out the + -- location of a @Located@ + -- value. + , unLoc :: a -- ^ Project the value + -- of type @a@ out of + -- a @Located a@, + -- discarding the + -- location. + } + +infix 5 `at` + +-- | Construct a @Located a@ from a value of type @a@ and a location. +-- @at@ is intended to be used infix, like @x \`at\` origin@. +at :: a -> Point (V a) -> Located a +at a p = Loc p a + +-- | Deconstruct a @Located a@ into a location and a value of type +-- @a@. @viewLoc@ can be especially useful in conjunction with the +-- @ViewPatterns@ extension. +viewLoc :: Located a -> (Point (V a), a) +viewLoc (Loc p a) = (p,a) + +-- | 'Located' is not a @Functor@, since changing the type could +-- change the type of the associated vector space, in which case the +-- associated location would no longer have the right type. 'mapLoc' +-- has an extra constraint specifying that the vector space must +-- stay the same. +-- +-- (Technically, one can say that for every vector space @v@, +-- @Located@ is a little-f (endo)functor on the category of types +-- with associated vector space @v@; but that is not covered by the +-- standard @Functor@ class.) +mapLoc :: (V a ~ V b) => (a -> b) -> Located a -> Located b +mapLoc f (Loc p a) = Loc p (f a) + +deriving instance (Eq (V a), Eq a ) => Eq (Located a) +deriving instance (Ord (V a), Ord a ) => Ord (Located a) +deriving instance (Show (V a), Show a) => Show (Located a) + +type instance V (Located a) = V a + +-- | @Located a@ is an instance of @HasOrigin@ whether @a@ is or not. +-- In particular, translating a @Located a@ simply translates the +-- associated point (and does /not/ affect the value of type @a@). +instance VectorSpace (V a) => HasOrigin (Located a) where + moveOriginTo o (Loc p a) = Loc (moveOriginTo o p) a + +-- | Applying a transformation @t@ to a @Located a@ results in the +-- transformation being applied to the location, and the /linear/ +-- /portion/ of @t@ being applied to the value of type @a@ (/i.e./ +-- it is not translated). +instance Transformable a => Transformable (Located a) where + transform t@(Transformation t1 t2 _) (Loc p a) + = Loc (transform t p) (transform (Transformation t1 t2 zeroV) a) + +-- | The envelope of a @Located a@ is the envelope of the @a@, +-- translated to the location. +instance Enveloped a => Enveloped (Located a) where + getEnvelope (Loc p a) = moveTo p (getEnvelope a) + +instance Enveloped a => Juxtaposable (Located a) where + juxtapose = juxtaposeDefault + +-- | The trace of a @Located a@ is the trace of the @a@, +-- translated to the location. +instance Traced a => Traced (Located a) where + getTrace (Loc p a) = moveTo p (getTrace a) + +instance Qualifiable a => Qualifiable (Located a) where + n |> (Loc p a) = Loc p (n |> a) + +type instance Codomain (Located a) = Located (Codomain a) + +instance (V a ~ V (Codomain a), Parametric a) => Parametric (Located a) where + (Loc x a) `atParam` p = Loc x (a `atParam` p) + +instance DomainBounds a => DomainBounds (Located a) where + domainLower (Loc _ a) = domainLower a + domainUpper (Loc _ a) = domainUpper a + +instance (V a ~ V (Codomain a), EndValues a) => EndValues (Located a) + +instance ( Codomain a ~ V a, Fractional (Scalar (V a)), AdditiveGroup (V a) + , Sectionable a, Parametric a + ) + => Sectionable (Located a) where + splitAtParam (Loc x a) p = (Loc x a1, Loc (x .+^ (a `atParam` p)) a2) + where (a1,a2) = splitAtParam a p + +instance (HasArcLength a, Fractional (Scalar (V a)), V a ~ V (Codomain a)) + => HasArcLength (Located a) where + arcLengthBounded eps (Loc _ a) = arcLengthBounded eps a + arcLengthToParam eps (Loc _ a) l = arcLengthToParam eps a l diff --git a/src/Diagrams/Names.hs b/src/Diagrams/Names.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Names.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Names +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Names can be given to subdiagrams, and subdiagrams can later be +-- queried by name. This module exports types for representing names +-- and subdiagrams, and various functions for working with them. +-- +----------------------------------------------------------------------------- + +module Diagrams.Names + ( -- * Names + + AName, Name, IsName(..), (.>) + , Qualifiable(..) + + -- * Subdiagrams + + , Subdiagram, mkSubdiagram, subPoint, getSub, rawSub, location + + -- * Subdiagram maps + + , SubMap, fromNames, rememberAs, lookupSub + + -- * Naming things + + , named, nameSub, namePoint, localize + + -- * Querying by name + + , names + , withName, withNameAll, withNames + + ) where + +import Data.Semigroup +import Data.VectorSpace + +import Diagrams.Core (HasLinearMap, OrderedField, Point) +import Diagrams.Core.Names +import Diagrams.Core.Types + +-- | Attach an atomic name to a diagram. +named :: ( IsName n + , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) + => n -> QDiagram b v m -> QDiagram b v m +named = nameSub mkSubdiagram + +-- | Attach an atomic name to a certain point (which may be computed +-- from the given diagram), treated as a subdiagram with no content +-- and a point envelope. +namePoint :: ( IsName n + , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) + => (QDiagram b v m -> Point v) -> n -> QDiagram b v m -> QDiagram b v m +namePoint p = nameSub (subPoint . p) + diff --git a/src/Diagrams/Parametric.hs b/src/Diagrams/Parametric.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Parametric.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Parametric +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Type classes for things which are parameterized in some way, /e.g./ +-- segments and trails. +-- +----------------------------------------------------------------------------- +module Diagrams.Parametric + ( + -- * Parametric functions + stdTolerance + , Codomain, Parametric(..) + + , DomainBounds(..), EndValues(..), Sectionable(..), HasArcLength(..) + + -- * Adjusting + , adjust + , AdjustOpts(..), AdjustMethod(..), AdjustSide(..) + + ) where + +import Diagrams.Core +import Diagrams.Util + +import Data.Default.Class +import Data.VectorSpace +import qualified Numeric.Interval as I + +-- | Codomain of parametric classes. This is usually either @(V p)@, for relative +-- vector results, or @(Point (V p))@, for functions with absolute coordinates. +type family Codomain p :: * + +-- | Type class for parametric functions. +class Parametric p where + + -- | 'atParam' yields a parameterized view of an object as a + -- continuous function. It is designed to be used infix, like @path + -- ``atParam`` 0.5@. + atParam :: p -> Scalar (V p) -> Codomain p + +-- | Type class for parametric functions with a bounded domain. The +-- default bounds are @[0,1]@. +-- +-- Note that this domain indicates the main \"interesting\" portion of the +-- function. It must be defined within this range, but for some instances may +-- still have sensible values outside. +class DomainBounds p where + -- | 'domainLower' defaults to being constantly 0 (for vector spaces with + -- numeric scalars). + domainLower :: p -> Scalar (V p) + + default domainLower :: Num (Scalar (V p)) => p -> Scalar (V p) + domainLower = const 0 + + -- | 'domainUpper' defaults to being constantly 1 (for vector spaces + -- with numeric scalars). + domainUpper :: p -> Scalar (V p) + + default domainUpper :: Num (Scalar (V p)) => p -> Scalar (V p) + domainUpper = const 1 + +-- | Type class for querying the values of a parametric object at the +-- ends of its domain. +class (Parametric p, DomainBounds p) => EndValues p where + -- | 'atStart' is the value at the start of the domain. That is, + -- + -- > atStart x = x `atParam` domainLower x + -- + -- This is the default implementation, but some representations will + -- have a more efficient and/or precise implementation. + atStart :: p -> Codomain p + atStart x = x `atParam` domainLower x + + -- | 'atEnd' is the value at the end of the domain. That is, + -- + -- > atEnd x = x `atParam` domainUpper x + -- + -- This is the default implementation, but some representations will + -- have a more efficient and/or precise implementation. + atEnd :: p -> Codomain p + atEnd x = x `atParam` domainUpper x + +-- | Return the lower and upper bounds of a parametric domain together +-- as a pair. +domainBounds :: DomainBounds p => p -> (Scalar (V p), Scalar (V p)) +domainBounds x = (domainLower x, domainUpper x) + +-- | Type class for parametric objects which can be split into +-- subobjects. +-- +-- Minimal definition: Either 'splitAtParam' or 'section'. +class DomainBounds p => Sectionable p where + -- | 'splitAtParam' splits an object @p@ into two new objects + -- @(l,r)@ at the parameter @t@, where @l@ corresponds to the + -- portion of @p@ for parameter values from @0@ to @t@ and @r@ for + -- to that from @t@ to @1@. The following property should hold: + -- + -- > prop_splitAtParam f t u = + -- > | u < t = atParam f u == atParam l (u / t) + -- > | otherwise = atParam f u == atParam f t ??? atParam l ((u - t) / (domainUpper f - t)) + -- > where (l,r) = splitAtParam f t + -- + -- where @(???) = (^+^)@ if the codomain is a vector type, or + -- @const flip@ if the codomain is a point type. Stated more + -- intuitively, all this is to say that the parameterization + -- scales linearly with splitting. + -- + -- 'splitAtParam' can also be used with parameters outside the + -- range of the domain. For example, using the parameter @2@ with + -- a path (where the domain is the default @[0,1]@) gives two + -- result paths where the first is the original path extended to + -- the parameter 2, and the second result path travels /backwards/ + -- from the end of the first to the end of the original path. + splitAtParam :: p -> Scalar (V p) -> (p, p) + splitAtParam x t + = ( section x (domainLower x) t + , section x t (domainUpper x)) + + -- | Extract a particular section of the domain, linearly + -- reparameterized to the same domain as the original. Should + -- satisfy the property: + -- + -- > prop_section x l u t = + -- > let s = section x l u + -- > in domainBounds x == domainBounds x + -- > && (x `atParam` lerp l u t) == (s `atParam` t) + -- + -- That is, the section should have the same domain as the + -- original, and the reparameterization should be linear. + section :: p -> Scalar (V p) -> Scalar (V p) -> p + default section :: Fractional (Scalar (V p)) => p -> Scalar (V p) -> Scalar (V p) -> p + section x t1 t2 = snd (splitAtParam (fst (splitAtParam x t2)) (t1/t2)) + + -- | Flip the parameterization on the domain. This has the + -- following default definition: + -- + -- > reverse x = section x (domainUpper x) (domainLower x) + reverseDomain :: p -> p + reverseDomain x = section x (domainUpper x) (domainLower x) + +-- | The standard tolerance used by @std...@ functions (like +-- 'stdArcLength' and 'stdArcLengthToParam', currently set at +-- @1e-6@. +stdTolerance :: Fractional a => a +stdTolerance = 1e-6 + +-- | Type class for parametric things with a notion of arc length. +class Parametric p => HasArcLength p where + + -- | @arcLengthBounded eps x@ approximates the arc length of @x@. + -- The true arc length is guaranteed to lie within the interval + -- returned, which will have a size of at most @eps@. + arcLengthBounded :: Scalar (V p) -> p -> I.Interval (Scalar (V p)) + + -- | @arcLength eps s@ approximates the arc length of @x@ up to the + -- accuracy @eps@ (plus or minus). + arcLength :: Scalar (V p) -> p -> Scalar (V p) + default arcLength :: Fractional (Scalar (V p)) => Scalar (V p ) -> p -> Scalar (V p) + arcLength eps = I.midpoint . arcLengthBounded eps + + -- | Approximate the arc length up to a standard accuracy of + -- 'stdTolerance' (@1e-6@). + stdArcLength :: p -> Scalar (V p) + default stdArcLength :: Fractional (Scalar (V p)) => p -> Scalar (V p) + stdArcLength = arcLength stdTolerance + + -- | @'arcLengthToParam' eps s l@ converts the absolute arc length + -- @l@, measured from the start of the domain, to a parameter on + -- the object @s@. The true arc length at the parameter returned + -- is guaranteed to be within @eps@ of the requested arc length. + -- + -- This should work for /any/ arc length, and may return any + -- parameter value (not just parameters in the domain). + arcLengthToParam :: Scalar (V p) -> p -> Scalar (V p) -> Scalar (V p) + + -- | A simple interface to convert arc length to a parameter, + -- guaranteed to be accurate within 'stdTolerance', or @1e-6@. + stdArcLengthToParam :: p -> Scalar (V p) -> Scalar (V p) + default stdArcLengthToParam :: Fractional (Scalar (V p)) + => p -> Scalar (V p) -> Scalar (V p) + stdArcLengthToParam = arcLengthToParam stdTolerance + +-------------------------------------------------- +-- Adjusting length +-------------------------------------------------- + +-- | 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 = AO { adjMethod :: AdjustMethod v + , adjSide :: AdjustSide + , adjEps :: Scalar v + , 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 = AO def def stdTolerance Proxy + +-- | Adjust the length of a parametric object such as a segment or +-- trail. The second parameter is an option record which controls how +-- the adjustment should be performed; see 'AdjustOpts'. +adjust :: (DomainBounds a, Sectionable a, HasArcLength a, Fractional (Scalar (V a))) + => a -> AdjustOpts (V a) -> a +adjust s opts = section s + (if adjSide opts == End then domainLower s else getParam s) + (if adjSide opts == Start then domainUpper s else domainUpper s - getParam (reverseDomain s)) + where + getParam seg = case adjMethod opts of + ByParam p -> -p * bothCoef + ByAbsolute len -> param (-len * bothCoef) + ToAbsolute len -> param (absDelta len * bothCoef) + where + param = arcLengthToParam eps seg + absDelta len = arcLength eps s - len + bothCoef = if adjSide opts == Both then 0.5 else 1 + eps = adjEps opts diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE TypeFamilies - , MultiParamTypeClasses - , FlexibleInstances - , FlexibleContexts - , DeriveFunctor - , GeneralizedNewtypeDeriving - , UndecidableInstances - , ScopedTypeVariables - #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Path @@ -14,288 +15,98 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- This module defines /trails/ (translationally invariant sequences --- of linear or cubic Bézier segments) and /paths/ (collections of --- concretely located trails). Trails and paths can be used for --- drawing shapes, laying out other diagrams, clipping, and other --- things. +-- This module defines /paths/, which are collections of concretely +-- located 'Trail's. Many drawing systems (cairo, svg, ...) have a +-- similar notion of \"path\". Note that paths with multiple trails +-- are necessary for being able to draw /e.g./ filled objects with +-- holes in them. -- ----------------------------------------------------------------------------- module Diagrams.Path ( - -- * Constructing path-like things - PathLike(..), fromSegments, fromOffsets, fromVertices, segmentsFromVertices - , pathLikeFromTrail - - -- * Closeable things - - , Closeable(..) - - -- * Trails - - , Trail(..) - - -- ** Computing with trails - - , trailSegments' - , trailOffsets, trailOffset - , trailVertices, reverseTrail - , addClosingSegment - , fixTrail - -- * Paths - , Path(..) + Path(..) - -- ** Constructing paths from trails + -- * Constructing paths + -- $construct , pathFromTrail , pathFromTrailAt + , pathFromLocTrail - -- ** Computing with paths + -- * Eliminating paths , pathVertices , pathOffsets , pathCentroid + , fixPath + + -- * Modifying paths + , scalePath , reversePath - , fixPath -- * Miscellaneous - , explodeTrail , explodePath - , (~~) + , partitionPath ) where -import Diagrams.Core -import Diagrams.Core.Points - -import Diagrams.Align -import Diagrams.Segment -import Diagrams.Points -import Diagrams.Transform - -import Data.VectorSpace -import Data.AffineSpace - -import Control.Newtype hiding (under) -import Data.Semigroup -import qualified Data.Foldable as F - -import Data.List (mapAccumL) - -import Control.Arrow ((***), first, second) - ------------------------------------------------------------- --- PathLike class ------------------------------------------------------------- - --- | Type class for path-like things, which must be monoids. --- Instances include 'Trail's, 'Path's, and two-dimensional 'Diagram's. -class (Monoid' p, VectorSpace (V p)) => PathLike p where - - pathLike :: Point (V p) -- ^ The starting point of the - -- path. Some path-like things - -- (e.g. 'Trail's) may ignore this. - -> 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. -fromSegments :: PathLike p => [Segment (V p)] -> p -fromSegments = pathLike origin False - --- | Construct an open path-like thing of linear segments from a list --- of offsets. The starting point is the origin. -fromOffsets :: PathLike p => [V p] -> p -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. -fromVertices :: PathLike p => [Point (V p)] -> p -fromVertices [] = mempty -fromVertices vvs@(v:_) = pathLike v False (segmentsFromVertices vvs) - --- | 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) - ------------------------------------------------------------- --- Closeable class ------------------------------------------------------------- - --- | Path-like things that can be \"open\" or \"closed\". -class PathLike p => Closeable p where - -- | \"Open\" a path-like thing. - open :: p -> p - - -- | \"Close\" a path-like thing, by implicitly connecting the - -- endpoint(s) back to the starting point(s). - close :: p -> p - -instance VectorSpace v => Closeable (Trail v) where - close (Trail segs _) = Trail segs True - open (Trail segs _) = Trail segs False - -instance VectorSpace v => Closeable (Path v) where - close = (over Path . map . second) close - open = (over Path . map . second) open - ------------------------------------------------------------- --- 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 - -instance Semigroup (Trail v) where - Trail t1 c1 <> Trail t2 c2 = Trail (t1 ++ t2) (c1 || c2) - --- | The empty trail has no segments. Trails are composed via --- concatenation. @t1 ``mappend`` t2@ is closed iff either @t1@ or --- @t2@ are. -instance Monoid (Trail v) where - mempty = Trail [] False - mappend = (<>) - --- | 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 - pathLike _ cl segs = Trail segs cl - -instance HasLinearMap v => Transformable (Trail v) where - transform t (Trail segs c) = Trail (transform t segs) c - --- | The envelope for a trail is based at the trail's start. -instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Trail v) where - - getEnvelope (Trail segs _) = - foldr (\seg bds -> moveOriginBy (negateV . segOffset $ seg) bds <> getEnvelope seg) - mempty - segs - - -- XXX can we improve the efficiency of the above? E.g. note the - -- last segment in each trail ends up getting translated O(n) times, - -- so overall we do O(n^2) work! (to find the max over the bounds - -- for O(n) segments, where the ith segment requires working through - -- a stack of i translations...) - -- - -- The idea would be to first convert to a list of FixedSegments (to - -- cache the translation work) then take the bounds of those. - -- - -- Also, use a balanced fold! - -- - -- Need to make some benchmarks I guess. - -instance HasLinearMap v => Renderable (Trail v) NullBackend where - render _ _ = mempty - ------------------------------------------------------------- --- Computing with trails --------------------------------- ------------------------------------------------------------- - --- | @trailSegments'@ is like 'trailSegments', but explicitly includes --- the implicit closing segment at the end of the list for closed trails. -trailSegments' :: AdditiveGroup v => Trail v -> [Segment v] -trailSegments' t | isClosed t = trailSegments t - ++ [straight . negateV . trailOffset $ t] - | otherwise = trailSegments t - --- | 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 - --- | Reverse a trail's direction of travel. -reverseTrail :: AdditiveGroup v => Trail v -> Trail v -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) - --- | If the trail is closed, this adds in the closing segment. Otherwise, --- the trail is returned unmodified. -addClosingSegment :: AdditiveGroup v => Trail v -> Trail v -addClosingSegment t | isClosed t = Trail (trailSegments t ++ [closeSeg]) False - | otherwise = t - where closeSeg = Linear . negateV $ trailOffset t +import Diagrams.Align +import Diagrams.Core +import Diagrams.Core.Points +import Diagrams.Located +import Diagrams.Points +import Diagrams.Segment +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.Transform --- | Convert a starting point and a trail into a list of fixed segments. -fixTrail :: AdditiveGroup v => Point v -> Trail v -> [FixedSegment v] -fixTrail start t = zipWith mkFixedSeg (trailVertices start t) - (trailSegments $ addClosingSegment t) +import Control.Arrow (first, second, (***)) +import Control.Newtype hiding (under) +import Data.AffineSpace +import qualified Data.Foldable as F +import Data.List (mapAccumL, partition) +import Data.Semigroup +import Data.VectorSpace ------------------------------------------------------------ -- Paths ------------------------------------------------- ------------------------------------------------------------ --- | A /path/ is a (possibly empty) list of trails, with each --- trail paired with an absolute starting point. Hence, paths --- are /not/ translationally invariant, and form a monoid under --- superposition. -newtype Path v = Path { pathTrails :: [(Point v, Trail v)] } - deriving (Show, Semigroup, Monoid, Eq, Ord) +-- | A /path/ is a (possibly empty) list of 'Located' 'Trail's. +-- Hence, unlike trails, paths are not translationally invariant, +-- and they form a monoid under /superposition/ (placing one path on +-- top of another) rather than concatenation. +newtype Path v = Path { pathTrails :: [Located (Trail v)] } + deriving (Semigroup, Monoid) +deriving instance Show v => Show (Path v) +deriving instance Eq v => Eq (Path v) +deriving instance Ord v => Ord (Path v) + type instance V (Path v) = v -instance Newtype (Path v) [(Point v, Trail v)] where +instance Newtype (Path v) [Located (Trail v)] where pack = Path unpack = pathTrails instance VectorSpace v => HasOrigin (Path v) where - moveOriginTo = over Path . map . first . moveOriginTo + moveOriginTo = over Path . map . moveOriginTo --- | Paths are (of course) path-like. 'fromSegments' creates a path --- with start point at the origin. -instance VectorSpace v => PathLike (Path v) where - pathLike s cl segs = Path [(s, pathLike origin cl segs)] +-- | Paths are trail-like; a trail can be used to construct a +-- singleton path. +instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Path v) where + trailLike = Path . (:[]) -- See Note [Transforming paths] -instance HasLinearMap v => Transformable (Path v) where - transform t = (over Path . map) (transform t *** transform t) +instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) + => Transformable (Path v) where + transform = over Path . map . transform {- ~~~~ Note [Transforming paths] @@ -307,11 +118,13 @@ of the v's are inside Points and hence ought to be translated. -} +instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => IsPrim (Path v) + instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Path v) where getEnvelope = F.foldMap trailEnvelope . pathTrails -- this type signature is necessary to work around an apparent bug in ghc 6.12.1 - where trailEnvelope :: (Point v, Trail v) -> Envelope v - trailEnvelope (p, t) = moveOriginTo ((-1) *. p) (getEnvelope t) + where trailEnvelope :: Located (Trail v) -> Envelope v + trailEnvelope (viewLoc -> (p, t)) = moveOriginTo ((-1) *. p) (getEnvelope t) instance (InnerSpace v, OrderedField (Scalar v)) => Juxtaposable (Path v) where juxtapose = juxtaposeDefault @@ -319,68 +132,76 @@ instance (InnerSpace v, OrderedField (Scalar v)) => Alignable (Path v) where alignBy = alignByDefault -instance HasLinearMap v => Renderable (Path v) NullBackend where +instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) + => Renderable (Path v) NullBackend where render _ _ = mempty ------------------------------------------------------------ --- Constructing paths from trails ------------------------ +-- Constructing paths ------------------------------------ ------------------------------------------------------------ +-- $construct +-- Since paths are 'TrailLike', any function producing a 'TrailLike' +-- can be used to construct a (singleton) path. The functions in this +-- section are provided for convenience. + -- | Convert a trail to a path beginning at the origin. -pathFromTrail :: AdditiveGroup v => Trail v -> Path v -pathFromTrail t = Path [(origin, t)] +pathFromTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Path v +pathFromTrail = trailLike . (`at` origin) -- | Convert a trail to a path with a particular starting point. -pathFromTrailAt :: Trail v -> Point v -> Path v -pathFromTrailAt t p = Path [(p, t)] +pathFromTrailAt :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Point v -> Path v +pathFromTrailAt t p = trailLike (t `at` p) +-- | Convert a located trail to a singleton path. This is equivalent +-- to 'trailLike', but provided with a more specific name and type +-- for convenience. +pathFromLocTrail :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> Path v +pathFromLocTrail = trailLike + ------------------------------------------------------------ --- Computing with paths ---------------------------------- +-- Eliminating paths ------------------------------------- ------------------------------------------------------------ --- | Extract the vertices of a path. -pathVertices :: AdditiveGroup v => Path v -> [[Point v]] -pathVertices = map (uncurry trailVertices) . pathTrails +-- | Extract the vertices of a path, resulting in a separate list of +-- vertices for each component trail (see 'trailVertices'). +pathVertices :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [[Point v]] +pathVertices = map trailVertices . pathTrails --- | Compute the total offset of each trail comprising a path. -pathOffsets :: AdditiveGroup v => Path v -> [v] -pathOffsets = map (trailOffset . snd) . pathTrails +-- | Compute the total offset of each trail comprising a path (see 'trailOffset'). +pathOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [v] +pathOffsets = map (trailOffset . unLoc) . pathTrails --- | Compute the /centroid/ of a path (/i.e./ the average of its --- vertices). -pathCentroid :: (VectorSpace v, Fractional (Scalar v)) => Path v -> Point v +-- | Compute the /centroid/ of a path (/i.e./ the average location of +-- its vertices). +pathCentroid :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> Point v pathCentroid = centroid . concat . pathVertices --- | Scale a path using its centroid (see 'pathCentroid') as the base --- point for the scale. -scalePath :: (HasLinearMap v, VectorSpace v, Fractional (Scalar v), Eq (Scalar v)) - => Scalar v -> Path v -> Path v -scalePath d p = (scale d `under` translation (origin .-. pathCentroid p)) p +-- | Convert a path into a list of lists of 'FixedSegment's. +fixPath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [[FixedSegment v]] +fixPath = map fixTrail . unpack --- | Reverse the direction of all the component trails of a path. -reversePath :: AdditiveGroup v => Path v -> Path v -reversePath = (over Path . map) reverseRootedTrail +-- | \"Explode\" a path by exploding every component trail (see +-- 'explodeTrail'). +explodePath :: (VectorSpace (V t), TrailLike t) => Path (V t) -> [[t]] +explodePath = map explodeTrail . pathTrails --- | Convert a path into a list of lists of 'FixedSegment's. -fixPath :: AdditiveGroup v => Path v -> [[FixedSegment v]] -fixPath = map (uncurry fixTrail) . unpack +-- | Partition a path into two paths based on a predicate on trails: +-- the first containing all the trails for which the predicate returns +-- @True@, and the second containing the remaining trails. +partitionPath :: (Located (Trail v) -> Bool) -> Path v -> (Path v, Path v) +partitionPath p = (pack *** pack) . partition p . unpack ------------------------------------------------------------ --- Other functions --------------------------------------- +-- Modifying paths --------------------------------------- ------------------------------------------------------------ --- | Given a starting point, \"explode\" a trail by turning each --- segment (including the implicit closing segment, if the trail is --- closed) into its own separate path. Useful for (say) applying a --- different style to each segment. -explodeTrail :: (VectorSpace (V p), PathLike p) => Point (V p) -> Trail (V p) -> [p] -explodeTrail start = snd . mapAccumL mkPath start . trailSegments' - where mkPath p seg = (p .+^ segOffset seg, pathLike p False [seg]) - --- | \"Explode\" a path by exploding every component trail (see 'explodeTrail'). -explodePath :: (VectorSpace (V p), PathLike p) => Path (V p) -> [[p]] -explodePath = map (uncurry explodeTrail) . pathTrails +-- | Scale a path using its centroid (see 'pathCentroid') as the base +-- point for the scale. +scalePath :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) + => Scalar v -> Path v -> Path v +scalePath d p = (scale d `under` translation (origin .-. pathCentroid p)) p --- | Create a single-segment path between two given points. -(~~) :: PathLike p => Point (V p) -> Point (V p) -> p -p1 ~~ p2 = fromVertices [p1, p2] +-- | Reverse all the component trails of a path. +reversePath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> Path v +reversePath = (over Path . map) reverseLocTrail diff --git a/src/Diagrams/Points.hs b/src/Diagrams/Points.hs --- a/src/Diagrams/Points.hs +++ b/src/Diagrams/Points.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -8,23 +8,28 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- Some miscellaneous utilities for working with points. +-- Points in space. For more tools for working with points and +-- vectors, see "Data.AffineSpace" and "Diagrams.Coordinates". -- ----------------------------------------------------------------------------- module Diagrams.Points - ( centroid + ( -- * Points + Point, origin, (*.) + -- * Point-related utilities + , centroid + ) where -import Diagrams.Coordinates -import Diagrams.Core.Points +import Diagrams.Coordinates +import Diagrams.Core.Points -import Control.Newtype +import Control.Newtype -import Control.Arrow ((&&&)) +import Control.Arrow ((&&&)) -import Data.VectorSpace +import Data.VectorSpace -- | The centroid of a set of /n/ points is their sum divided by /n/. centroid :: (VectorSpace v, Fractional (Scalar v)) => [Point v] -> Point v diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -20,10 +20,6 @@ -- * Standard library - -- | Nice syntax for constructing and pattern-matching - -- literal points and vectors. - , module Diagrams.Coordinates - -- | Attributes (color, line style, etc.) and styles. , module Diagrams.Attributes @@ -33,10 +29,22 @@ -- | Combining multiple diagrams into one. , module Diagrams.Combinators + -- | Giving concrete locations to translation-invariant things. + , module Diagrams.Located + -- | Linear and cubic bezier segments. , module Diagrams.Segment - -- | Trails and paths. + -- | Trails. + , module Diagrams.Trail + + -- | Parametrization of segments and trails. + , module Diagrams.Parametric + + -- | Trail-like things. + , module Diagrams.TrailLike + + -- | Paths. , module Diagrams.Path -- | Cubic splines. @@ -50,6 +58,25 @@ -- good old-fashioned, axis-aligned bounding boxes. , module Diagrams.BoundingBox + -- | Giving names to subdiagrams and later retrieving + -- subdiagrams by name. + , module Diagrams.Names + + -- | Envelopes, aka functional bounding regions. + , module Diagrams.Envelope + + -- | Traces, aka embedded raytracers, for finding points on + -- the boundary of a diagram. + , module Diagrams.Trace + + -- | A query is a function that maps points in a vector space + -- to values in some monoid; they can be used to annotate + -- the points of a diagram with some values. + , module Diagrams.Query + + -- | Utilities for working with points. + , module Diagrams.Points + -- | A wide range of things (shapes, transformations, -- combinators) specific to creating two-dimensional -- diagrams. @@ -80,25 +107,34 @@ , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 ) where -import Diagrams.Core +import Diagrams.Core -import Diagrams.Align -import Diagrams.Animation -import Diagrams.Attributes -import Diagrams.BoundingBox -import Diagrams.Combinators -import Diagrams.Coordinates -import Diagrams.CubicSpline -import Diagrams.Path -import Diagrams.Segment -import Diagrams.Transform -import Diagrams.TwoD -import Diagrams.Util +import Diagrams.Align +import Diagrams.Animation +import Diagrams.Attributes +import Diagrams.BoundingBox +import Diagrams.Combinators +import Diagrams.Coordinates +import Diagrams.CubicSpline +import Diagrams.Envelope +import Diagrams.Located +import Diagrams.Names +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Points +import Diagrams.Query +import Diagrams.Segment +import Diagrams.Trace +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.Transform +import Diagrams.TwoD +import Diagrams.Util -import Data.Colour hiding (atop, AffineSpace(..)) -import Data.Colour.Names -import Data.Semigroup -import Data.VectorSpace hiding (Sum(..)) -import Data.AffineSpace -import Data.Active -import Control.Applicative +import Control.Applicative +import Data.Active +import Data.AffineSpace +import Data.Colour hiding (AffineSpace (..), atop) +import Data.Colour.Names +import Data.Semigroup +import Data.VectorSpace hiding (Sum (..)) diff --git a/src/Diagrams/Query.hs b/src/Diagrams/Query.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Query.hs @@ -0,0 +1,19 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Query +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- A query is a function that maps points in a vector space to values +-- in some monoid. Queries naturally form a monoid, with two queries +-- being combined pointwise. +-- +----------------------------------------------------------------------------- + +module Diagrams.Query + ( Query(..), query, sample, value, resetValue, clearValue + + ) where + +import Diagrams.Core diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -1,134 +1,205 @@ -{-# LANGUAGE TypeFamilies - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , DeriveFunctor - , UndecidableInstances - #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Segment --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- A /segment/ is a translation-invariant, atomic path. There are two --- types: linear (/i.e./ just a straight line to the endpoint) and --- cubic Bézier curves (/i.e./ a curve to an endpoint with two control --- points). This module contains tools for creating and manipulating --- segments, as well as a definition of segments with a fixed location --- (useful for backend implementors). +-- A /segment/ is a translation-invariant, atomic path. Currently, +-- there are two types: linear (/i.e./ just a straight line to the +-- endpoint) and cubic Bézier curves (/i.e./ a curve to an endpoint +-- with two control points). This module contains tools for creating +-- and manipulating segments, as well as a definition of segments with +-- a fixed location (useful for backend implementors). -- -- Generally speaking, casual users of diagrams should not need this --- module; the higher-level functionality provided by "Diagrams.Path" --- should usually suffice instead. However, directly manipulating --- segments can occasionally be useful. +-- module; the higher-level functionality provided by +-- "Diagrams.Trail", "Diagrams.TrailLike", and "Diagrams.Path" should +-- usually suffice. However, directly manipulating segments can +-- occasionally be useful. -- ----------------------------------------------------------------------------- module Diagrams.Segment - ( -- * Constructing segments + ( -- * Open/closed tags - Segment(..), straight, bezier3 + Open, Closed - -- * Computing with segments - , atParam, segOffset - , reverseSegment - , splitAtParam, arcLength - , arcLengthToParam + -- * Segment offsets - -- * Adjusting segments - , adjustSegment - , AdjustOpts(..) - , AdjustMethod(..) - , AdjustSide(..) + , Offset(..), segOffset - , adjustSegmentToParams + -- * Constructing and modifying segments + , Segment(..), straight, bezier3, bézier3, reverseSegment + -- * Fixed (absolutely located) segments , FixedSegment(..) , mkFixedSeg, fromFixedSeg - , fAtParam + -- * Segment measures + -- $segmeas + + , SegCount(..) + , ArcLength(..), getArcLengthCached, getArcLengthFun, getArcLengthBounded + , TotalOffset(..) + , OffsetEnvelope(..) + , SegMeasure + ) where -import Diagrams.Core +import Control.Applicative (liftA2) +import Data.AffineSpace +import Data.Default.Class +import Data.FingerTree +import Data.Monoid.MList +import Data.Semigroup +import Data.VectorSpace hiding (Sum (..)) +import Numeric.Interval (Interval (..)) +import qualified Numeric.Interval as I -import Diagrams.Solve -import Diagrams.Util +import Diagrams.Core +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Solve +import Diagrams.Util -import Data.Default -import Data.AffineSpace -import Data.VectorSpace -import Control.Applicative (liftA2) -import Data.Semigroup +------------------------------------------------------------ +-- Open/closed type tags --------------------------------- +------------------------------------------------------------ +-- Eventually we should use DataKinds for this, but not until we drop +-- support for GHC 7.4. + +-- | Type tag for open segments. +data Open + +-- | Type tag for closed segments. +data Closed + ------------------------------------------------------------ +-- Segment offsets --------------------------------------- +------------------------------------------------------------ + +-- | The /offset/ of a segment is the vector from its starting point +-- to its end. The offset for an /open/ segment is determined by +-- the context, /i.e./ its endpoint is not fixed. The offset for a +-- /closed/ segment is stored explicitly, /i.e./ its endpoint is at +-- a fixed offset from its start. +data Offset c v where + OffsetOpen :: Offset Open v + OffsetClosed :: v -> Offset Closed v + +deriving instance Show v => Show (Offset c v) +deriving instance Eq v => Eq (Offset c v) +deriving instance Ord v => Ord (Offset c v) + +instance Functor (Offset c) where + fmap _ OffsetOpen = OffsetOpen + fmap f (OffsetClosed v) = OffsetClosed (f v) + +type instance V (Offset c v) = v + +instance HasLinearMap v => Transformable (Offset c v) where + transform = fmap . apply + +------------------------------------------------------------ -- Constructing segments --------------------------------- ------------------------------------------------------------ --- | The atomic constituents of paths are /segments/, which are single --- straight lines or cubic Bézier curves. Segments are +-- | The atomic constituents of the concrete representation currently +-- used for trails are /segments/, currently limited to +-- single straight lines or cubic Bézier curves. Segments are -- /translationally invariant/, that is, they have no particular -- \"location\" and are unaffected by translations. They are, -- however, affected by other transformations such as rotations and -- scales. -data Segment v = Linear v -- ^ A linear segment with given offset. - | Cubic v v v -- ^ A cubic Bézier segment specified by - -- three offsets from the starting - -- point to the first control point, - -- second control point, and ending - -- point, respectively. +data Segment c v + = Linear (Offset c v) + -- ^ A linear segment with given offset. + + | Cubic v v (Offset c v) + -- ^ A cubic Bézier 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 +-- Note, can't yet have Haddock comments on GADT constructors; see +-- http://trac.haskell.org/haddock/ticket/43. For now we don't need +-- Segment to be a GADT but we might in the future. (?) -instance HasLinearMap v => Transformable (Segment v) where +type instance V (Segment c v) = v + +instance HasLinearMap v => Transformable (Segment c v) where transform = fmap . apply -instance HasLinearMap v => Renderable (Segment v) NullBackend where +instance HasLinearMap v => Renderable (Segment c v) NullBackend where render _ _ = mempty -- | @'straight' v@ constructs a translationally invariant linear -- segment with direction and length given by the vector @v@. -straight :: v -> Segment v -straight = Linear +straight :: v -> Segment Closed v +straight = Linear . OffsetClosed -- 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 +-- | @bezier3 c1 c2 x@ constructs a translationally invariant cubic -- Bézier curve where the offsets from the first endpoint to the -- first and second control point and endpoint are respectively --- given by @v1@, @v2@, and @v3@. -bezier3 :: v -> v -> v -> Segment v -bezier3 = Cubic +-- given by @c1@, @c2@, and @x@. +bezier3 :: v -> v -> v -> Segment Closed v +bezier3 c1 c2 x = Cubic c1 c2 (OffsetClosed x) +-- | @bézier3@ is the same as @bezier3@, but with more snobbery. +bézier3 :: v -> v -> v -> Segment Closed v +bézier3 = bezier3 + +type instance Codomain (Segment Closed v) = v + -- | '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 +instance (VectorSpace v, Num (Scalar v)) => Parametric (Segment Closed v) where + atParam (Linear (OffsetClosed x)) t = t *^ x + atParam (Cubic c1 c2 (OffsetClosed x2)) t = (3 * t'*t'*t ) *^ c1 + ^+^ (3 * t'*t *t ) *^ c2 + ^+^ ( t *t *t ) *^ x2 + where t' = 1-t +instance Num (Scalar v) => DomainBounds (Segment Closed v) + +instance (VectorSpace v, Num (Scalar v)) => EndValues (Segment Closed v) where + atStart = const zeroV + atEnd (Linear (OffsetClosed v)) = v + atEnd (Cubic _ _ (OffsetClosed v)) = v + -- | Compute the offset from the start of a segment to the -- end. Note that in the case of a Bézier segment this is /not/ the -- same as the length of the curve itself; for that, see 'arcLength'. -segOffset :: Segment v -> v -segOffset (Linear v) = v -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) +segOffset :: Segment Closed v -> v +segOffset (Linear (OffsetClosed v)) = v +segOffset (Cubic _ _ (OffsetClosed v)) = v ------------------------------------------------------------ -- Computing segment envelope ------------------------------ @@ -157,12 +228,12 @@ -} -- | The envelope for a segment is based at the segment's start. -instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Segment v) where +instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Segment Closed v) where getEnvelope (s@(Linear {})) = mkEnvelope $ \v -> maximum . map (\t -> ((s `atParam` t) <.> v) / magnitudeSq v) $ [0,1] - getEnvelope (s@(Cubic c1 c2 x2)) = mkEnvelope $ \v -> + getEnvelope (s@(Cubic c1 c2 (OffsetClosed x2))) = mkEnvelope $ \v -> maximum . map (\t -> ((s `atParam` t) <.> v) / magnitudeSq v) $ [0,1] ++ @@ -175,143 +246,66 @@ -- 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@. --- 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' 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 - 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 - --- | @'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 - --- 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...) - --------------------------------------------------- --- Adjusting segment length --------------------------------------------------- - --- | 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) +instance (VectorSpace v, Fractional (Scalar v)) => Sectionable (Segment Closed v) where + splitAtParam (Linear (OffsetClosed x1)) t = (left, right) + where left = straight p + right = straight (x1 ^-^ p) + p = lerp zeroV x1 t + splitAtParam (Cubic c1 c2 (OffsetClosed x2)) t = (left, right) + where left = bezier3 a b e + right = bezier3 (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 --- | How should a segment, trail, or path be adjusted? -data AdjustOpts v = ALO { adjMethod :: AdjustMethod v - , adjSide :: AdjustSide - , adjEps :: Scalar v - , adjOptsvProxy__ :: Proxy v - } + reverseDomain = reverseSegment -instance Fractional (Scalar v) => Default (AdjustMethod v) where - def = ByParam 0.2 +-- | Reverse the direction of a segment. +reverseSegment :: AdditiveGroup v => Segment Closed v -> Segment Closed v +reverseSegment (Linear (OffsetClosed v)) = straight (negateV v) +reverseSegment (Cubic c1 c2 (OffsetClosed x2)) = bezier3 (c2 ^-^ x2) (c1 ^-^ x2) (negateV x2) -instance Default AdjustSide where - def = Both +instance (InnerSpace v, Floating (Scalar v), Ord (Scalar v), AdditiveGroup v) + => HasArcLength (Segment Closed v) where -instance Fractional (Scalar v) => Default (AdjustOpts v) where - def = ALO def def (1/10^(10 :: Integer)) Proxy + arcLengthBounded _ (Linear (OffsetClosed x1)) = I.singleton $ magnitude x1 + arcLengthBounded m s@(Cubic c1 c2 (OffsetClosed x2)) + | ub - lb < m = I lb ub + | otherwise = arcLengthBounded (m/2) l + arcLengthBounded (m/2) r + where (l,r) = s `splitAtParam` 0.5 + ub = sum (map magnitude [c1, c2 ^-^ c1, x2 ^-^ c2]) + lb = magnitude x2 --- | 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 - (if adjSide opts == End then 0 else getParam s) - (if adjSide opts == Start then 0 else 1 - getParam (reverseSegment s)) - where - getParam seg = case adjMethod opts of - ByParam p -> -p * bothCoef - ByAbsolute len -> param (-len * bothCoef) - ToAbsolute len -> param (absDelta len * bothCoef) - where - param l = arcLengthToParam seg l eps - absDelta len = arcLength s eps - len - bothCoef = if adjSide opts == Both then 0.5 else 1 - eps = adjEps opts + arcLengthToParam m s _ | arcLength m s == 0 = 0.5 + arcLengthToParam m s@(Linear {}) len = len / arcLength m s + arcLengthToParam m s@(Cubic {}) len + | len `I.elem` (I (-m/2) (m/2)) = 0 + | len < 0 = - arcLengthToParam m (fst (splitAtParam s (-1))) (-len) + | len `I.elem` slen = 1 + | len > I.sup slen = 2 * arcLengthToParam m (fst (splitAtParam s 2)) len + | len < I.sup llen = (*0.5) $ arcLengthToParam m l len + | otherwise = (+0.5) . (*0.5) + $ arcLengthToParam (9*m/10) r (len - I.midpoint llen) + where (l,r) = s `splitAtParam` 0.5 + llen = arcLengthBounded (m/10) l + slen = arcLengthBounded m s --- | 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)) + -- 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...) ------------------------------------------------------------ -- Fixed segments ------------------------------------------------------------ -- | @FixedSegment@s are like 'Segment's except that they have --- absolute locations. +-- absolute locations. @FixedSegment v@ is isomorphic to @Located +-- (Segment Closed v)@, as witnessed by 'mkFixedSeg' and +-- 'fromFixedSeg', but @FixedSegment@ is convenient when one needs +-- the absolute locations of the vertices and control points. data FixedSegment v = FLinear (Point v) (Point v) | FCubic (Point v) (Point v) (Point v) (Point v) deriving Show @@ -346,34 +340,136 @@ instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (FixedSegment v) where getEnvelope f = moveTo p (getEnvelope s) - where (p, s) = fromFixedSeg f + where (p, s) = viewLoc $ fromFixedSeg f -- Eventually we might decide it's cleaner/more efficient (?) to -- have all the computation in the FixedSegment instance of -- Envelope, and implement the Segment instance in terms of it, -- instead of the other way around --- | 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) +-- | Create a 'FixedSegment' from a located 'Segment'. +mkFixedSeg :: AdditiveGroup v => Located (Segment Closed v) -> FixedSegment v +mkFixedSeg (viewLoc -> (p, Linear (OffsetClosed v))) + = FLinear p (p .+^ v) +mkFixedSeg (viewLoc -> (p, Cubic c1 c2 (OffsetClosed x2))) + = FCubic p (p .+^ c1) (p .+^ c2) (p .+^ x2) --- | Decompose a 'FixedSegment' into a starting point and a 'Segment'. -fromFixedSeg :: AdditiveGroup v => FixedSegment v -> (Point v, Segment v) -fromFixedSeg (FLinear p1 p2) = (p1, Linear (p2 .-. p1)) -fromFixedSeg (FCubic x1 c1 c2 x2) = (x1, Cubic (c1 .-. x1) (c2 .-. x1) (x2 .-. x1)) +-- | Convert a 'FixedSegment' back into a located 'Segment'. +fromFixedSeg :: AdditiveGroup v => FixedSegment v -> Located (Segment Closed v) +fromFixedSeg (FLinear p1 p2) = straight (p2 .-. p1) `at` p1 +fromFixedSeg (FCubic x1 c1 c2 x2) = bezier3 (c1 .-. x1) (c2 .-. x1) (x2 .-. x1) `at` x1 --- | 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 +type instance Codomain (FixedSegment v) = Point v - p21 = alerp p11 p12 t - p22 = alerp p12 p13 t +instance VectorSpace v => Parametric (FixedSegment v) where + atParam (FLinear p1 p2) t = alerp p1 p2 t + atParam (FCubic x1 c1 c2 x2) t = p3 + where p11 = alerp x1 c1 t + p12 = alerp c1 c2 t + p13 = alerp c2 x2 t - p3 = alerp p21 p22 t + p21 = alerp p11 p12 t + p22 = alerp p12 p13 t + + p3 = alerp p21 p22 t + +------------------------------------------------------------ +-- Segment measures -------------------------------------- +------------------------------------------------------------ + +-- $segmeas +-- Trails store a sequence of segments in a fingertree, which can +-- automatically track various monoidal \"measures\" on segments. + +-- | A type to track the count of segments in a 'Trail'. +newtype SegCount = SegCount { getSegCount :: Sum Int } + deriving (Semigroup, Monoid) + +-- | A type to represent the total arc length of a chain of +-- segments. The first component is a \"standard\" arc length, +-- computed to within a tolerance of @10e-6@. The second component is +-- a generic arc length function taking the tolerance as an +-- argument. +newtype ArcLength v = ArcLength + { getArcLength :: (Sum (Interval (Scalar v)), Scalar v -> Sum (Interval (Scalar v))) } + +-- | Project out the cached arc length, stored together with error +-- bounds. +getArcLengthCached :: ArcLength v -> Interval (Scalar v) +getArcLengthCached = getSum . fst . getArcLength + +-- | Project out the generic arc length function taking the tolerance as +-- an argument. +getArcLengthFun :: ArcLength v -> Scalar v -> Interval (Scalar v) +getArcLengthFun = fmap getSum . snd . getArcLength + +-- | Given a specified tolerance, project out the cached arc length if +-- it is accurate enough; otherwise call the generic arc length +-- function with the given tolerance. +getArcLengthBounded :: (Num (Scalar v), Ord (Scalar v)) + => Scalar v -> ArcLength v -> Interval (Scalar v) +getArcLengthBounded eps al + | I.width cached <= eps = cached + | otherwise = getArcLengthFun al eps + where + cached = getArcLengthCached al +deriving instance (Num (Scalar v), Ord (Scalar v)) => Semigroup (ArcLength v) +deriving instance (Num (Scalar v), Ord (Scalar v)) => Monoid (ArcLength v) + +-- | A type to represent the total cumulative offset of a chain of +-- segments. +newtype TotalOffset v = TotalOffset { getTotalOffset :: v } + +instance AdditiveGroup v => Semigroup (TotalOffset v) where + TotalOffset v1 <> TotalOffset v2 = TotalOffset (v1 ^+^ v2) + +instance AdditiveGroup v => Monoid (TotalOffset v) where + mempty = TotalOffset zeroV + mappend = (<>) + +-- | A type to represent the offset and envelope of a chain of +-- segments. They have to be paired into one data structure, since +-- combining the envelopes of two consecutive chains needs to take +-- the offset of the the offset of the first into account. +data OffsetEnvelope v = OffsetEnvelope + { oeOffset :: TotalOffset v + , oeEnvelope :: Envelope v + } + +instance (InnerSpace v, OrderedField (Scalar v)) => Semigroup (OffsetEnvelope v) where + (OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 e2) + = OffsetEnvelope + (o1 <> o2) + (e1 <> moveOriginBy (negateV . getTotalOffset $ o1) e2) + +-- | @SegMeasure@ collects up all the measurements over a chain of +-- segments. +type SegMeasure v = SegCount + ::: ArcLength v + ::: OffsetEnvelope v + ::: () + -- unfortunately we can't cache Trace, since there is not a generic + -- instance Traced (Segment Closed v), only Traced (Segment Closed R2). + +instance (InnerSpace v, OrderedField (Scalar v)) + => Measured (SegMeasure v) (SegMeasure v) where + measure = id + +instance (OrderedField (Scalar v), InnerSpace v) + => Measured (SegMeasure v) (Segment Closed v) where + measure s = (SegCount . Sum $ 1) + + -- cache arc length with two orders of magnitude more + -- accuracy than standard, so we have a hope of coming out + -- with an accurate enough total arc length for + -- reasonable-length trails + *: (ArcLength $ ( Sum $ arcLengthBounded (stdTolerance/100) s + , Sum . flip arcLengthBounded s + ) + ) + + *: (OffsetEnvelope + (TotalOffset . segOffset $ s) + (getEnvelope s) + ) + *: () diff --git a/src/Diagrams/Solve.hs b/src/Diagrams/Solve.hs --- a/src/Diagrams/Solve.hs +++ b/src/Diagrams/Solve.hs @@ -14,10 +14,10 @@ , cubForm ) where -import Data.List (maximumBy) -import Data.Ord (comparing) +import Data.List (maximumBy) +import Data.Ord (comparing) -import Diagrams.Util (tau) +import Diagrams.Util (tau) ------------------------------------------------------------ -- Quadratic formula @@ -31,7 +31,7 @@ -- so arbitrarily return 0 | a == 0 && b == 0 && c == 0 = [0] - -- c = 0 + -- c /= 0 | a == 0 && b == 0 = [] -- linear @@ -39,6 +39,9 @@ -- no real solutions | d < 0 = [] + + -- ax^2 + c = 0 + | b == 0 = [sqrt (-c/a), -sqrt (-c/a)] -- multiplicity 2 solution | d == 0 = [-b/(2*a)] diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -24,7 +24,7 @@ import Data.Semigroup import Data.AffineSpace -import Data.Monoid.PosInf (minimum) +import Data.Monoid.Inf (minimum) import Data.VectorSpace import Diagrams.Core @@ -38,6 +38,8 @@ instance Transformable Ellipsoid where transform t1 (Ellipsoid t2) = Ellipsoid (t1 <> t2) + +instance IsPrim Ellipsoid instance Renderable Ellipsoid NullBackend where render _ _ = mempty diff --git a/src/Diagrams/Trace.hs b/src/Diagrams/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Trace.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Trace +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- \"Traces\", aka embedded raytracers, for finding points on the edge +-- of a diagram. See "Diagrams.Core.Trace" for internal +-- implementation details. +-- +----------------------------------------------------------------------------- + +module Diagrams.Trace + ( -- * Types + Trace, Traced + + -- * Diagram traces + , trace, setTrace, withTrace + + -- * Querying traces + , traceV, traceP, maxTraceV, maxTraceP + + -- * Subdiagram traces + , boundaryFrom, boundaryFromMay + + ) where + +import Diagrams.Core (HasLinearMap, Point, Subdiagram, + location, origin, setTrace, trace) +import Diagrams.Core.Trace + +import Data.Maybe +import Data.VectorSpace (Scalar, negateV) +import Diagrams.Combinators (withTrace) + +-- | Compute the furthest point on the boundary of a subdiagram, +-- beginning from the location (local origin) of the subdiagram and +-- moving in the direction of the given vector. If there is no such +-- point, the origin is returned; see also 'boundaryFromMay'. +boundaryFrom :: (HasLinearMap v, Ord (Scalar v)) => Subdiagram b v m -> v -> Point v +boundaryFrom s v = fromMaybe origin $ boundaryFromMay s v + +-- | Compute the furthest point on the boundary of a subdiagram, +-- beginning from the location (local origin) of the subdiagram and +-- moving in the direction of the given vector, or @Nothing@ if +-- there is no such point. +boundaryFromMay :: (HasLinearMap v, Ord (Scalar v)) => Subdiagram b v m -> v -> Maybe (Point v) +boundaryFromMay s v = traceP (location s) (negateV v) s diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Trail.hs @@ -0,0 +1,880 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Trail +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- This module defines /trails/, translationally invariant paths +-- through space. Trails form a central part of the diagrams-lib API, +-- so the documentation for this module merits careful study. +-- +-- Related modules include: +-- +-- * The 'TrailLike' class ("Diagrams.TrailLike") exposes a generic +-- API for building a wide range of things out of trails. +-- +-- * 'Path's ("Diagrams.Path") are collections of 'Located' +-- ("Diagrams.Located") trails. +-- +-- * Trails are composed of 'Segment's (see "Diagrams.Segment"), +-- though most users should not need to work with segments directly. +-- +----------------------------------------------------------------------------- + +module Diagrams.Trail + ( + -- * Type definitions + + -- ** Lines and loops + + Trail'(..) + + , glueLine + , closeLine + , cutLoop + + -- ** Generic trails + + , Trail(..) + , wrapTrail, wrapLine, wrapLoop + , onTrail, onLine + + , glueTrail, closeTrail, cutTrail + + -- * Constructing trails + + , emptyLine, emptyTrail + , lineFromVertices, trailFromVertices + , lineFromOffsets, trailFromOffsets + , lineFromSegments, trailFromSegments + + -- * Eliminating trails + + , withTrail', withTrail, withLine + , isLineEmpty, isTrailEmpty + , isLine, isLoop + , trailSegments, lineSegments, loopSegments + , onLineSegments + , trailOffsets, trailOffset + , lineOffsets, lineOffset, loopOffsets + , trailVertices, lineVertices, loopVertices + , fixTrail + + -- * Modifying trails + + , reverseTrail, reverseLocTrail + , reverseLine, reverseLocLine + , reverseLoop, reverseLocLoop + + -- * Internals + -- $internals + + -- ** Type tags + + , Line, Loop + + -- ** Segment trees + + , SegTree(..), trailMeasure, numSegs, offset + + ) where + +import Control.Arrow ((***)) +import Data.AffineSpace +import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), (<|), + (|>)) +import qualified Data.FingerTree as FT +import qualified Data.Foldable as F +import Data.Monoid.MList +import Data.Semigroup +import Data.VectorSpace hiding (Sum (..)) +import qualified Numeric.Interval as I + +import Diagrams.Core hiding ((|>)) +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Segment + +-- $internals +-- +-- Most users of diagrams should not need to use anything in this +-- section directly, but they are exported on the principle that we +-- can't forsee what uses people might have for them. + +------------------------------------------------------------ +-- FingerTree instances +------------------------------------------------------------ + +type instance V (FingerTree m a) = V a + +instance ( HasLinearMap (V a), InnerSpace (V a), OrderedField (Scalar (V a)) + , FT.Measured m a, Transformable a + ) + => Transformable (FingerTree m a) where + transform = FT.fmap' . transform + +------------------------------------------------------------ +-- Segment trees ----------------------------------------- +------------------------------------------------------------ + +-- | A @SegTree@ represents a sequence of closed segments, stored in a +-- fingertree so we can easily recover various monoidal measures of +-- the segments (number of segments, arc length, envelope...) and +-- also easily slice and dice them according to the measures +-- (/e.g./, split off the smallest number of segments from the +-- beginning which have a combined arc length of at least 5). +newtype SegTree v = SegTree + { getSegTree :: FingerTree (SegMeasure v) (Segment Closed v) } + deriving (Eq, Ord, Show) + +type instance V (SegTree v) = v + +deriving instance (OrderedField (Scalar v), InnerSpace v) + => Monoid (SegTree v) +deriving instance (OrderedField (Scalar v), InnerSpace v) + => FT.Measured (SegMeasure v) (SegTree v) +deriving instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) + => Transformable (SegTree v) + +type instance Codomain (SegTree v) = v + +instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) + => Parametric (SegTree v) where + atParam t p = offset . fst $ splitAtParam t p + +instance Num (Scalar v) => DomainBounds (SegTree v) + +instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v), Num (Scalar v)) + => EndValues (SegTree v) + +instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) + => Sectionable (SegTree v) where + splitAtParam (SegTree t) p + | p < 0 = case FT.viewl t of + EmptyL -> emptySplit + seg :< t' -> + case seg `splitAtParam` (p * tSegs) of + (seg1, seg2) -> ( SegTree $ FT.singleton seg1 + , SegTree $ seg2 <| t' + ) + | p >= 1 = case FT.viewr t of + EmptyR -> emptySplit + t' :> seg -> + case seg `splitAtParam` (1 - (1 - p)*tSegs) of + (seg1, seg2) -> ( SegTree $ t' |> seg1 + , SegTree $ FT.singleton seg2 + ) + | otherwise = case FT.viewl after of + EmptyL -> emptySplit + seg :< after' -> + case seg `splitAtParam` (snd . properFraction $ p * tSegs) of + (seg1, seg2) -> ( SegTree $ before |> seg1 + , SegTree $ seg2 <| after' + ) + where + (before, after) = FT.split ((p * tSegs <) . numSegs) t + tSegs = numSegs t + emptySplit = (SegTree t, SegTree t) + + -- XXX seems like it should be possible to collapse some of the + -- above cases into one? + +instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) + => HasArcLength (SegTree v) where + arcLengthBounded eps t + -- Use the cached value if it is accurate enough; otherwise fall + -- back to recomputing a more accurate value + | I.width i <= eps = i + | otherwise = fun (eps / numSegs t) + where + i = trailMeasure (I.singleton 0) + (getArcLengthCached :: ArcLength v -> I.Interval (Scalar v)) + t + fun = trailMeasure (const 0) + (getArcLengthFun :: ArcLength v -> Scalar v -> I.Interval (Scalar v)) + t + + arcLengthToParam eps st@(SegTree t) l + | l < 0 = case FT.viewl t of + EmptyL -> 0 + seg :< _ -> arcLengthToParam eps seg l / tSegs + | l >= totalAL = case FT.viewr t of + EmptyR -> 0 + t' :> seg -> + let p = arcLengthToParam (eps/2) seg + (l - arcLength (eps/2) (SegTree t')) + in (p - 1)/tSegs + 1 + | otherwise = case FT.viewl after of + EmptyL -> 0 + seg :< after' -> + let p = arcLengthToParam (eps/2) seg + (l - arcLength (eps/2) (SegTree before)) + in (numSegs before + p) / tSegs + where + totalAL = arcLength eps st + tSegs = numSegs t + before, after :: FingerTree (SegMeasure v) (Segment Closed v) + (before, after) = FT.split ((>= l) . trailMeasure 0 (I.midpoint . (getArcLengthBounded eps :: ArcLength v -> I.Interval (Scalar v)))) t + +-- | Given a default result (to be used in the case of an empty +-- trail), and a function to map a single measure to a result, +-- extract the given measure for a trail and use it to compute a +-- result. Put another way, lift a function on a single measure +-- (along with a default value) to a function on an entire trail. +trailMeasure :: ( InnerSpace v, OrderedField (Scalar v) + , SegMeasure v :>: m, FT.Measured (SegMeasure v) t + ) + => a -> (m -> a) -> t -> a +trailMeasure d f = option d f . get . FT.measure + +-- | Compute the number of segments of anything measured by +-- 'SegMeasure' (/e.g./ @SegMeasure@ itself, @Segment@, @SegTree@, +-- @Trail@s...) +numSegs :: ( Floating (Scalar v), Num c, Ord (Scalar v), InnerSpace v, + FT.Measured (SegMeasure v) a + ) + => a -> c +numSegs = fromIntegral . trailMeasure 0 (getSum . getSegCount) + +-- | Compute the total offset of anything measured by 'SegMeasure'. +offset :: ( Floating (Scalar v), Ord (Scalar v), InnerSpace v, + FT.Measured (SegMeasure v) t + ) + => t -> v +offset = trailMeasure zeroV (getTotalOffset . oeOffset) + +------------------------------------------------------------ +-- Trails ------------------------------------------------ +------------------------------------------------------------ + +-- Eventually we should use DataKinds for this, but not until we drop +-- support for GHC 7.4. + +-- | Type tag for trails with distinct endpoints. +data Line + +-- | Type tag for \"loopy\" trails which return to their starting +-- point. +data Loop + +-------------------------------------------------- +-- The Trail' type + +-- | Intuitively, a trail is a single, continuous path through space. +-- However, a trail has no fixed starting point; it merely specifies +-- /how/ to move through space, not /where/. For example, \"take +-- three steps forward, then turn right twenty degrees and take two +-- more steps\" is an intuitive analog of a trail; these +-- instructions specify a path through space from any given starting +-- location. To be precise, trails are /translation-invariant/; +-- applying a translation to a trail has no effect. +-- +-- A @'Located' Trail@, on the other hand, is a trail paired with +-- some concrete starting location (\"start at the big tree on the +-- corner, then take three steps forward, ...\"). See the +-- "Diagrams.Located" module for help working with 'Located' values. +-- +-- Formally, the semantics of a trail is a continuous (though not +-- necessarily differentiable) function from the real interval [0,1] +-- to vectors in some vector space. (In contrast, a 'Located' trail +-- is a continuous function from [0,1] to /points/ in some /affine/ +-- space.) +-- +-- There are two types of trails: +-- +-- * A \"line\" (think of the \"train\", \"subway\", or \"bus\" +-- variety, rather than the \"straight\" variety...) is a trail +-- with two distinct endpoints. Actually, a line can have the +-- same start and end points, but it is still /drawn/ as if it had +-- distinct endpoints: the two endpoints will have the appropriate +-- end caps, and the trail will not be filled. Lines have a +-- @Monoid@ instance where @mappend@ corresponds to concatenation, +-- /i.e./ chaining one line after the other. +-- +-- * A \"loop\" is required to end in the same place it starts (that +-- is, t(0) = t(1)). Loops are filled and are drawn as one +-- continuous loop, with the appropriate join at the +-- start/endpoint rather than end caps. Loops do not have a +-- @Monoid@ instance. +-- +-- To convert between lines and loops, see 'glueLine', +-- 'closeLine', and 'cutLoop'. +-- +-- To construct trails, see 'emptyTrail', 'trailFromSegments', +-- 'trailFromVertices', 'trailFromOffsets', and friends. You can +-- also get any type of trail from any function which returns a +-- 'TrailLike' (/e.g./ functions in "Diagrams.TwoD.Shapes", and many +-- others; see "Diagrams.TrailLike"). +-- +-- To extract information from trails, see 'withLine', 'isLoop', +-- 'trailSegments', 'trailOffsets', 'trailVertices', and friends. + +data Trail' l v where + Line :: SegTree v -> Trail' Line v + Loop :: SegTree v -> Segment Open v -> Trail' Loop v + +-- | A generic eliminator for 'Trail'', taking functions specifying +-- what to do in the case of a line or a loop. +withTrail' :: (Trail' Line v -> r) -> (Trail' Loop v -> r) -> Trail' l v -> r +withTrail' line loop t@(Line{}) = line t +withTrail' line loop t@(Loop{}) = loop t + +deriving instance Show v => Show (Trail' l v) +deriving instance Eq v => Eq (Trail' l v) +deriving instance Ord v => Ord (Trail' l v) + +type instance V (Trail' l v) = v + +type instance Codomain (Trail' l v) = v + +instance (OrderedField (Scalar v), InnerSpace v) => Semigroup (Trail' Line v) where + (Line t1) <> (Line t2) = Line (t1 `mappend` t2) + +-- | The empty trail is constantly the zero vector. Trails are +-- composed via concatenation. Note that only lines have a monoid +-- instance (and not loops). +instance (OrderedField (Scalar v), InnerSpace v) => Monoid (Trail' Line v) where + mempty = emptyLine + mappend = (<>) + +instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) + => Transformable (Trail' l v) where + transform tr (Line t ) = Line (transform tr t) + transform tr (Loop t s) = Loop (transform tr t) (transform tr s) + +-- | The envelope for a trail is based at the trail's start. +instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Trail' l v) where + getEnvelope = withTrail' ftEnv (ftEnv . cutLoop) + where + ftEnv :: Trail' Line v -> Envelope v + ftEnv (Line t) = trailMeasure mempty oeEnvelope $ t + +instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) + => Renderable (Trail' o v) NullBackend where + render _ _ = mempty + +instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) + => Parametric (Trail' l v) where + atParam t p = withTrail' + (\(Line segT) -> segT `atParam` p) + (\l -> cutLoop l `atParam` p') + t + where + pf = snd . properFraction $ p + p' | p >= 0 = pf + | otherwise = 1 + pf + +instance Num (Scalar v) => DomainBounds (Trail' l v) + +instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) + => EndValues (Trail' l v) + +instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) + => Sectionable (Trail' Line v) where + splitAtParam (Line t) p = (Line t1, Line t2) + where + (t1, t2) = splitAtParam t p + +instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) + => HasArcLength (Trail' l v) where + arcLengthBounded eps = + withTrail' + (\(Line t) -> arcLengthBounded eps t) + (arcLengthBounded eps . cutLoop) + + arcLengthToParam eps tr l = + withTrail' + (\(Line t) -> arcLengthToParam eps t l) + (\lp -> arcLengthToParam eps (cutLoop lp) l) + tr + +-------------------------------------------------- +-- The Trail type + +-- | @Trail@ is a wrapper around @Trail'@, hiding whether the +-- underlying @Trail'@ is a line or loop (though which it is can be +-- recovered; see /e.g./ 'withTrail'). +data Trail v where + Trail :: Trail' l v -> Trail v + +deriving instance Show v => Show (Trail v) + +instance Eq v => Eq (Trail v) where + t1 == t2 = + withTrail + (\ln1 -> withTrail (\ln2 -> ln1 == ln2) (const False) t2) + (\lp1 -> withTrail (const False) (\lp2 -> lp1 == lp2) t2) + t1 + +instance Ord v => Ord (Trail v) where + compare t1 t2 = + withTrail + (\ln1 -> withTrail (\ln2 -> compare ln1 ln2) (const LT) t2) + (\lp1 -> withTrail (const GT) (\lp2 -> compare lp1 lp2) t2) + t1 + +-- | Two @Trail@s are combined by first ensuring they are both lines +-- (using 'cutTrail' on loops) and then concatenating them. The +-- result, in general, is a line. However, there is a special case +-- for the empty line, which acts as the identity (so combining the +-- empty line with a loop results in a loop). +instance (OrderedField (Scalar v), InnerSpace v) => Semigroup (Trail v) where + (Trail (Line (SegTree ft))) <> t2 | FT.null ft = t2 + t1 <> (Trail (Line (SegTree ft))) | FT.null ft = t1 + t1 <> t2 = flip withLine t1 $ \l1 -> + flip withLine t2 $ \l2 -> + wrapLine (l1 <> l2) + +-- | @Trail@s are combined as described in the 'Semigroup' instance; +-- the empty line is the identity element, with special cases so +-- that combining the empty line with a loop results in the +-- unchanged loop (in all other cases loops will be cut). Note that +-- this does, in fact, satisfy the monoid laws, though it is a bit +-- strange. Mostly it is provided for convenience, so one can work +-- directly with @Trail@s instead of working with @Trail' Line@s and +-- then wrapping. +instance (OrderedField (Scalar v), InnerSpace v) => Monoid (Trail v) where + mempty = wrapLine emptyLine + mappend = (<>) + +type instance V (Trail v) = v + +type instance Codomain (Trail v) = v + +instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) + => Transformable (Trail v) where + transform t = onTrail (transform t) (transform t) + +instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Trail v) where + getEnvelope = withTrail getEnvelope getEnvelope + +instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) + => Parametric (Trail v) where + atParam t p = withTrail (`atParam` p) (`atParam` p) t + +instance Num (Scalar v) => DomainBounds (Trail v) + +instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) + => EndValues (Trail v) + +-- | Note that there is no @Sectionable@ instance for @Trail' Loop@, +-- because it does not make sense (splitting a loop at a parameter +-- results in a single line, not two loops). However, it's +-- convenient to have a @Sectionable@ instance for @Trail@; if the +-- @Trail@ contains a loop the loop will first be cut and then +-- @splitAtParam@ called on the resulting line. This is +-- semantically a bit silly, so please don't rely on it. (*E.g.* if +-- this is really the behavior you want, consider first calling +-- 'cutLoop' yourself.) +instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) + => Sectionable (Trail v) where + splitAtParam t p = withLine ((wrapLine *** wrapLine) . (`splitAtParam` p)) t + +instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) + => HasArcLength (Trail v) where + arcLengthBounded = withLine . arcLengthBounded + arcLengthToParam eps tr al = withLine (\ln -> arcLengthToParam eps ln al) tr + +-------------------------------------------------- +-- Constructors and eliminators for Trail + +-- | A generic eliminator for 'Trail', taking functions specifying +-- what to do in the case of a line or a loop. +withTrail :: (Trail' Line v -> r) -> (Trail' Loop v -> r) -> Trail v -> r +withTrail line loop (Trail t) = withTrail' line loop t + +-- | Modify a @Trail@, specifying two separate transformations for the +-- cases of a line or a loop. +onTrail :: (Trail' Line v -> Trail' l1 v) -> (Trail' Loop v -> Trail' l2 v) + -> (Trail v -> Trail v) +onTrail o c = withTrail (wrapTrail . o) (wrapTrail . c) + +-- | An eliminator for @Trail@ based on eliminating lines: if the +-- trail is a line, the given function is applied; if it is a loop, it +-- is first converted to a line with 'cutLoop'. That is, +-- +-- @ +-- withLine f === 'withTrail' f (f . 'cutLoop') +-- @ +withLine :: (InnerSpace v, OrderedField (Scalar v)) + => (Trail' Line v -> r) -> Trail v -> r +withLine f = withTrail f (f . cutLoop) + +-- | Modify a @Trail@ by specifying a transformation on lines. If the +-- trail is a line, the transformation will be applied directly. If +-- it is a loop, it will first be cut using 'cutLoop', the +-- transformation applied, and then glued back into a loop with +-- 'glueLine'. That is, +-- +-- @ +-- onLine f === onTrail f (glueLine . f . cutLoop) +-- @ +-- +-- Note that there is no corresponding @onLoop@ function, because +-- there is no nice way in general to convert a line into a loop, +-- operate on it, and then convert back. +onLine :: (InnerSpace v, OrderedField (Scalar v)) + => (Trail' Line v -> Trail' Line v) -> Trail v -> Trail v +onLine f = onTrail f (glueLine . f . cutLoop) + +-- | Convert a 'Trail'' into a 'Trail', hiding the type-level +-- distinction between lines and loops. +wrapTrail :: Trail' l v -> Trail v +wrapTrail = Trail + +-- | Convert a line into a 'Trail'. This is the same as 'wrapTrail', +-- but with a more specific type, which can occasionally be +-- convenient for fixing the type of a polymorphic expression. +wrapLine :: Trail' Line v -> Trail v +wrapLine = wrapTrail + +-- | Convert a loop into a 'Trail'. This is the same as 'wrapTrail', +-- but with a more specific type, which can occasionally be +-- convenient for fixing the type of a polymorphic expression. +wrapLoop :: Trail' Loop v -> Trail v +wrapLoop = wrapTrail + +------------------------------------------------------------ +-- Constructing trails ----------------------------------- +------------------------------------------------------------ + +-- | The empty line, which is the identity for concatenation of lines. +emptyLine :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v +emptyLine = Line mempty + +-- | A wrapped variant of 'emptyLine'. +emptyTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v +emptyTrail = wrapLine emptyLine + +-- | Construct a line from a list of closed segments. +lineFromSegments :: (InnerSpace v, OrderedField (Scalar v)) + => [Segment Closed v] -> Trail' Line v +lineFromSegments = Line . SegTree . FT.fromList + +-- | @trailFromSegments === 'wrapTrail' . 'lineFromSegments'@, for +-- conveniently constructing a @Trail@ instead of a @Trail'@. +trailFromSegments :: (InnerSpace v, OrderedField (Scalar v)) + => [Segment Closed v] -> Trail v +trailFromSegments = wrapTrail . lineFromSegments + +-- | Construct a line containing only linear segments from a list of +-- vectors, where each vector represents the offset from one vertex +-- to the next. See also 'fromOffsets'. +-- +-- <> +-- +-- > import Diagrams.Coordinates +-- > lineFromOffsetsEx = strokeLine $ lineFromOffsets [ 2 & 1, 2 & (-1), 2 & 0.5 ] +lineFromOffsets :: (InnerSpace v, OrderedField (Scalar v)) + => [v] -> Trail' Line v +lineFromOffsets = lineFromSegments . map straight + +-- | @trailFromOffsets === 'wrapTrail' . 'lineFromOffsets'@, for +-- conveniently constructing a @Trail@ instead of a @Trail' Line@. +trailFromOffsets :: (InnerSpace v, OrderedField (Scalar v)) + => [v] -> Trail v +trailFromOffsets = wrapTrail . lineFromOffsets + +-- | Construct a line containing only linear segments from a list of +-- vertices. Note that only the relative offsets between the +-- vertices matters; the information about their absolute position +-- will be discarded. That is, for all vectors @v@, +-- +-- @ +-- lineFromVertices === lineFromVertices . 'translate' v +-- @ +-- +-- If you want to retain the position information, you should +-- instead use the more general 'fromVertices' function to +-- construct, say, a @'Located' ('Trail'' 'Line' v)@ or a @'Located' +-- ('Trail' v)@. +-- +-- <> +-- +-- > import Diagrams.Coordinates +-- > lineFromVerticesEx = pad 1.1 . centerXY . strokeLine +-- > $ lineFromVertices [origin, 0 & 1, 1 & 2, 5 & 1] +lineFromVertices :: (InnerSpace v, OrderedField (Scalar v)) + => [Point v] -> Trail' Line v +lineFromVertices [] = emptyLine +lineFromVertices [_] = emptyLine +lineFromVertices ps = lineFromSegments . map straight $ zipWith (.-.) (tail ps) ps + + +-- | @trailFromVertices === 'wrapTrail' . 'lineFromVertices'@, for +-- conveniently constructing a @Trail@ instead of a @Trail' Line@. +trailFromVertices :: (InnerSpace v, OrderedField (Scalar v)) + => [Point v] -> Trail v +trailFromVertices = wrapTrail . lineFromVertices + +------------------------------------------------------------ +-- Converting between lines and loops -------------------- +------------------------------------------------------------ + +-- | Make a line into a loop by \"gluing\" the endpoint to the +-- starting point. In particular, the offset of the final segment +-- is modified so that it ends at the starting point of the entire +-- trail. Typically, you would first construct a line which you +-- know happens to end where it starts, and then call 'glueLine' to +-- turn it into a loop. +-- +-- <> +-- +-- > import Diagrams.Coordinates +-- > glueLineEx = pad 1.1 . hcat' with {sep = 1} +-- > $ [almostClosed # strokeLine, almostClosed # glueLine # strokeLoop] +-- > +-- > almostClosed :: Trail' Line R2 +-- > almostClosed = fromOffsets [2 & (-1), (-3) & (-0.5), (-2) & 1, 1 & 0.5] +-- +-- @glueLine@ is left inverse to 'cutLoop', that is, +-- +-- @ +-- glueLine . cutLoop === id +-- @ +glueLine :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> Trail' Loop v +glueLine (Line (SegTree t)) = + case FT.viewr t of + FT.EmptyR -> Loop mempty (Linear OffsetOpen) + t' :> (Linear _) -> Loop (SegTree t') (Linear OffsetOpen) + t' :> (Cubic c1 c2 _) -> Loop (SegTree t') (Cubic c1 c2 OffsetOpen) + +-- | @glueTrail@ is a variant of 'glueLine' which works on 'Trail's. +-- It performs 'glueLine' on lines and is the identity on loops. +glueTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Trail v +glueTrail = onTrail glueLine id + +-- | Make a line into a loop by adding a new linear segment from the +-- line's end to its start. +-- +-- @closeLine@ does not have any particularly nice theoretical +-- properties, but can be useful /e.g./ when you want to make a +-- closed polygon out of a list of points where the initial point is +-- not repeated at the end. To use 'glueLine', one would first have +-- to duplicate the initial vertex, like +-- +-- @ +-- 'glueLine' . 'lineFromVertices' $ ps ++ [head ps] +-- @ +-- +-- Using @closeLine@, however, one can simply +-- +-- @ +-- closeLine . lineFromVertices $ ps +-- @ +-- +-- <> +-- +-- > closeLineEx = pad 1.1 . centerXY . hcat' with {sep = 1} +-- > $ [almostClosed # strokeLine, almostClosed # closeLine # strokeLoop] +closeLine :: Trail' Line v -> Trail' Loop v +closeLine (Line t) = Loop t (Linear OffsetOpen) + +-- | @closeTrail@ is a variant of 'closeLine' for 'Trail', which +-- performs 'closeLine' on lines and is the identity on loops. +closeTrail :: Trail v -> Trail v +closeTrail = onTrail closeLine id + +-- | Turn a loop into a line by \"cutting\" it at the common start/end +-- point, resulting in a line which just happens to start and end at +-- the same place. +-- +-- @cutLoop@ is right inverse to 'glueLine', that is, +-- +-- @ +-- glueLine . cutLoop === id +-- @ +cutLoop :: forall v. (InnerSpace v, OrderedField (Scalar v)) + => Trail' Loop v -> Trail' Line v +cutLoop (Loop (SegTree t) c) = + case (FT.null t, c) of + (True, Linear OffsetOpen) -> emptyLine + (_ , Linear OffsetOpen) -> Line (SegTree (t |> Linear off)) + (_ , Cubic c1 c2 OffsetOpen) -> Line (SegTree (t |> Cubic c1 c2 off)) + where + offV :: v + offV = negateV . trailMeasure zeroV (getTotalOffset . oeOffset) $ t + off = OffsetClosed offV + +-- | @cutTrail@ is a variant of 'cutLoop' for 'Trail'; it is the is +-- the identity on lines and performs 'cutLoop' on loops. +cutTrail :: (InnerSpace v, OrderedField (Scalar v)) + => Trail v -> Trail v +cutTrail = onTrail id cutLoop + +------------------------------------------------------------ +-- Eliminating trails ------------------------------------ +------------------------------------------------------------ + +-- | Test whether a line is empty. +isLineEmpty :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> Bool +isLineEmpty (Line (SegTree t)) = FT.null t + +-- | Test whether a trail is empty. Note that loops are never empty. +isTrailEmpty :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Bool +isTrailEmpty = withTrail isLineEmpty (const False) + +-- | Determine whether a trail is a line. +isLine :: Trail v -> Bool +isLine = not . isLoop + +-- | Determine whether a trail is a loop. +isLoop :: Trail v -> Bool +isLoop = withTrail (const False) (const True) + +-- | Extract the segments comprising a line. +lineSegments :: Trail' Line v -> [Segment Closed v] +lineSegments (Line (SegTree t)) = F.toList t + +-- | Modify a line by applying a function to its list of segments. +onLineSegments + :: (InnerSpace v, OrderedField (Scalar v)) + => ([Segment Closed v] -> [Segment Closed v]) + -> Trail' Line v -> Trail' Line v +onLineSegments f = lineFromSegments . f . lineSegments + +-- | Extract the segments comprising a loop: a list of closed +-- segments, and one final open segment. +loopSegments :: Trail' Loop v -> ([Segment Closed v], Segment Open v) +loopSegments (Loop (SegTree t) c) = (F.toList t, c) + +-- | Extract the segments of a trail. If the trail is a loop it will +-- first have 'cutLoop' applied. +trailSegments :: (InnerSpace v, OrderedField (Scalar v)) + => Trail v -> [Segment Closed v] +trailSegments = withLine lineSegments + +-- | Extract the offsets of the segments of a trail. +trailOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> [v] +trailOffsets = withLine lineOffsets + +-- | Compute the offset from the start of a trail to the end. Satisfies +-- +-- @ +-- trailOffset === sumV . trailOffsets +-- @ +-- +-- but is more efficient. +-- +-- <> +-- +-- > trailOffsetEx = (strokeLine almostClosed <> showOffset) # centerXY # pad 1.1 +-- > where showOffset = fromOffsets [trailOffset (wrapLine almostClosed)] +-- > # stroke # lc red # lw 0.05 +trailOffset :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> v +trailOffset = withLine lineOffset + +-- | Extract the offsets of the segments of a line. +lineOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> [v] +lineOffsets = map segOffset . lineSegments + +-- | Extract the offsets of the segments of a loop. +loopOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Loop v -> [v] +loopOffsets = lineOffsets . cutLoop + +-- | Compute the offset from the start of a line to the end. (Note, +-- there is no corresponding @loopOffset@ function because by +-- definition it would be constantly zero.) +lineOffset :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> v +lineOffset (Line t) = trailMeasure zeroV (getTotalOffset . oeOffset) t + +-- | Extract the vertices of a concretely located trail. Note that +-- for loops, the starting vertex will /not/ be repeated at the end. +-- If you want this behavior, you can use 'cutTrail' to make the +-- loop into a line first, which happens to repeat the same vertex +-- at the start and end, /e.g./ with @trailVertices . mapLoc +-- cutTrail@. +-- +-- Note that it does not make sense to ask for the vertices of a +-- 'Trail' by itself; if you want the vertices of a trail +-- with the first vertex at, say, the origin, you can use +-- @trailVertices . (`at` origin)@. +trailVertices :: (InnerSpace v, OrderedField (Scalar v)) + => Located (Trail v) -> [Point v] +trailVertices (viewLoc -> (p,t)) + = withTrail (lineVertices . (`at` p)) (loopVertices . (`at` p)) t + +-- | Extract the vertices of a concretely located line. See +-- 'trailVertices' for more information. +lineVertices :: (InnerSpace v, OrderedField (Scalar v)) + => Located (Trail' Line v) -> [Point v] +lineVertices (viewLoc -> (p,t)) + = segmentVertices p . lineSegments $ t + +-- | Extract the vertices of a concretely located loop. Note that the +-- initial vertex is not repeated at the end. See 'trailVertices' for +-- more information. +loopVertices :: (InnerSpace v, OrderedField (Scalar v)) + => Located (Trail' Loop v) -> [Point v] +loopVertices (viewLoc -> (p,t)) + = segmentVertices p . fst . loopSegments $ t + +segmentVertices :: AdditiveGroup v => Point v -> [Segment Closed v] -> [Point v] +segmentVertices p = scanl (.+^) p . map segOffset + +-- | Convert a concretely located trail into a list of fixed segments. +fixTrail :: (InnerSpace v, OrderedField (Scalar v)) + => Located (Trail v) -> [FixedSegment v] +fixTrail t = zipWith ((mkFixedSeg .) . at) + (trailSegments (unLoc t)) (trailVertices t) + +------------------------------------------------------------ +-- Modifying trails -------------------------------------- +------------------------------------------------------------ + +-- | Reverse a trail. Semantically, if a trail given by a function t +-- from [0,1] to vectors, then the reverse of t is given by t'(s) = +-- t(1-s). @reverseTrail@ is an involution, that is, +-- +-- @ +-- reverseTrail . reverseTrail === id +-- @ +reverseTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Trail v +reverseTrail = onTrail reverseLine reverseLoop + +-- | Reverse a concretely located trail. The endpoint of the original +-- trail becomes the starting point of the reversed trail, so the +-- original and reversed trails comprise exactly the same set of +-- points. @reverseLocTrail@ is an involution, /i.e./ +-- +-- @ +-- reverseLocTrail . reverseLocTrail === id +-- @ +reverseLocTrail :: (InnerSpace v, OrderedField (Scalar v)) + => Located (Trail v) -> Located (Trail v) +reverseLocTrail (viewLoc -> (p, t)) = reverseTrail t `at` (p .+^ trailOffset t) + +-- | Reverse a line. See 'reverseTrail'. +reverseLine :: (InnerSpace v, OrderedField (Scalar v)) + => Trail' Line v -> Trail' Line v +reverseLine = onLineSegments (reverse . map reverseSegment) + +-- | Reverse a concretely located line. See 'reverseLocTrail'. +reverseLocLine :: (InnerSpace v, OrderedField (Scalar v)) + => Located (Trail' Line v) -> Located (Trail' Line v) +reverseLocLine (viewLoc -> (p,l)) = reverseLine l `at` (p .+^ lineOffset l) + +-- | Reverse a loop. See 'reverseTrail'. +reverseLoop :: (InnerSpace v, OrderedField (Scalar v)) + => Trail' Loop v -> Trail' Loop v +reverseLoop = glueLine . reverseLine . cutLoop + +-- | Reverse a concretely located loop. See 'reverseLocTrail'. Note +-- that this is guaranteed to preserve the location. +reverseLocLoop :: (InnerSpace v, OrderedField (Scalar v)) + => Located (Trail' Loop v) -> Located (Trail' Loop v) +reverseLocLoop = mapLoc reverseLoop diff --git a/src/Diagrams/TrailLike.hs b/src/Diagrams/TrailLike.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TrailLike.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TrailLike +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- The 'TrailLike' class abstracts over anything which can be +-- constructed from a concretely located 'Trail', including +-- lines, loops, trails, paths, vertex lists, and diagrams. +-- +----------------------------------------------------------------------------- + +module Diagrams.TrailLike + ( + -- * The TrailLike class + + TrailLike(..) + + -- * Constructing TrailLikes + + , fromSegments, fromLocSegments, fromOffsets, fromLocOffsets, fromVertices + , (~~), explodeTrail + + ) where + +import Data.AffineSpace ((.-.)) +import Data.VectorSpace + +import Diagrams.Core +import Diagrams.Located +import Diagrams.Segment +import Diagrams.Trail + +------------------------------------------------------------ +-- TrailLike class +------------------------------------------------------------ + +-- | A type class for trail-like things, /i.e./ things which can be +-- constructed from a concretely located 'Trail'. Instances include +-- lines, loops, trails, paths, lists of vertices, two-dimensional +-- 'Diagram's, and 'Located' variants of all the above. +-- +-- Usually, type variables with 'TrailLike' constraints are used as +-- the /output/ types of functions, like +-- +-- @ +-- foo :: (TrailLike t) => ... -> t +-- @ +-- +-- Functions with such a type can be used to construct trails, +-- paths, diagrams, lists of points, and so on, depending on the +-- context. +-- +-- To write a function with a signature like the above, you can of +-- course call 'trailLike' directly; more typically, one would use +-- one of the provided functions like 'fromOffsets', 'fromVertices', +-- 'fromSegments', or '~~'. +class (InnerSpace (V t), OrderedField (Scalar (V t))) => TrailLike t where + + trailLike + :: Located (Trail (V t)) -- ^ The concretely located trail. Note + -- that some trail-like things + -- (e.g. 'Trail's) may ignore the + -- location. + -> t + +------------------------------------------------------------ +-- Instances --------------------------------------------- + +-- | A list of points is trail-like; this instance simply +-- computes the vertices of the trail, using 'trailVertices'. +instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike [Point v] where + trailLike = trailVertices + +-- | Lines are trail-like. If given a 'Trail' which contains a loop, +-- the loop will be cut with 'cutLoop'. The location is ignored. +instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Trail' Line v) where + trailLike = withTrail id cutLoop . unLoc + +-- | Loops are trail-like. If given a 'Trail' containing a line, the +-- line will be turned into a loop using 'glueLine'. The location +-- is ignored. +instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Trail' Loop v) where + trailLike = withTrail glueLine id . unLoc + +-- | 'Trail's are trail-like; the location is simply ignored. +instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Trail v) where + trailLike = unLoc + +-- | Translationally invariant things are trail-like as long as the +-- underlying type is. +instance TrailLike t => TrailLike (TransInv t) where + trailLike = TransInv . trailLike + +-- | 'Located' things are trail-like as long as the underlying type +-- is. The location is taken to be the location of the input +-- located trail. +instance TrailLike t => TrailLike (Located t) where + trailLike t = trailLike t `at` loc t + +------------------------------------------------------------ +-- Constructing TrailLike things ------------------------- +------------------------------------------------------------ + +-- | Construct a trail-like thing from a list of segments, with the +-- origin as the location. +-- +-- XXX example/picture +fromSegments :: TrailLike t => [Segment Closed (V t)] -> t +fromSegments = fromLocSegments . (`at` origin) + +-- | Construct a trail-like thing from a located list of segments. +fromLocSegments :: TrailLike t => Located [Segment Closed (V t)] -> t +fromLocSegments = trailLike . mapLoc trailFromSegments + +-- | Construct a trail-like thing of linear segments from a list +-- of offsets, with the origin as the location. +-- +-- XXX example/picture +fromOffsets :: TrailLike t => [V t] -> t +fromOffsets = trailLike . (`at` origin) . trailFromOffsets + +-- | Construct a trail-like thing of linear segments from a located +-- list of offsets. +fromLocOffsets :: (V (V t) ~ V t, TrailLike t) => Located [V t] -> t +fromLocOffsets = trailLike . mapLoc trailFromOffsets + +-- | Construct a trail-like thing connecting the given vertices with +-- linear segments, with the first vertex as the location. If no +-- vertices are given, the empty trail is used with the origin as +-- the location. +-- +-- XXX example/picture +fromVertices :: TrailLike t => [Point (V t)] -> t +fromVertices [] = trailLike (emptyTrail `at` origin) +fromVertices ps@(p:_) = trailLike (trailFromSegments (segmentsFromVertices ps) `at` p) + +segmentsFromVertices :: AdditiveGroup v => [Point v] -> [Segment Closed v] +segmentsFromVertices [] = [] +segmentsFromVertices vvs@(_:vs) = map straight (zipWith (flip (.-.)) vvs vs) + +-- | Create a linear trail between two given points. +(~~) :: TrailLike t => Point (V t) -> Point (V t) -> t +p1 ~~ p2 = fromVertices [p1, p2] + +-- | Given a concretely located trail, \"explode\" it by turning each +-- segment into its own separate trail. Useful for (say) applying a +-- different style to each segment. +explodeTrail :: (VectorSpace (V t), TrailLike t) => Located (Trail (V t)) -> [t] +explodeTrail = map (mkTrail . fromFixedSeg) . fixTrail + where + mkTrail = trailLike . mapLoc (trailFromSegments . (:[])) diff --git a/src/Diagrams/Transform.hs b/src/Diagrams/Transform.hs --- a/src/Diagrams/Transform.hs +++ b/src/Diagrams/Transform.hs @@ -1,22 +1,38 @@ ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Transform --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-13 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- Some convenient functions related to transformations. +-- Affine transformations, parameterized by any vector space. For +-- transformations on particular vector spaces, see /e.g./ +-- "Diagrams.TwoD.Transform". -- ----------------------------------------------------------------------------- module Diagrams.Transform - ( conjugate, under + ( -- * Transformations + Transformation, inv, transl, apply, papply - ) where + -- * The Transformable class + , Transformable(..) -import Diagrams.Core -import Data.Semigroup + -- * Some specific transformations + , translation, translate, moveTo, place, scaling, scale + -- * Miscellaneous transformation-related utilities + , conjugate, under + + -- * The HasOrigin class + + , HasOrigin(..), moveOriginBy + + ) where + +import Data.Semigroup +import Diagrams.Core + -- | Conjugate one transformation by another. @conjugate t1 t2@ is the -- transformation which performs first @t1@, then @t2@, then the -- inverse of @t1@. @@ -25,13 +41,15 @@ -- | Carry out some transformation \"under\" another one: @f ``under`` -- t@ first applies @t@, then @f@, then the inverse of @t@. For --- example, @'scaleX' 2 ``under`` 'rotationBy' (-1/8 :: CircleFrac)@ +-- example, @'scaleX' 2 ``under`` 'rotationBy' (-1/8 :: Turn)@ -- is the transformation which scales by a factor of 2 along the -- diagonal line y = x. -- -- Note that -- --- > (transform t2) `under` t1 == transform (conjugate t1 t2) +-- @ +-- (transform t2) `under` t1 == transform (conjugate t1 t2) +-- @ -- -- for all transformations @t1@ and @t2@. under :: Transformable a => (a -> a) -> Transformation (V a) -> a -> a diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD @@ -65,12 +67,13 @@ -- * Angles , tau , Angle(..) - , CircleFrac(..), Rad(..), Deg(..) + , Turn(..), CircleFrac, Rad(..), Deg(..) , fullCircle, convertAngle -- * Paths -- ** Stroking - , stroke, stroke', strokeT, strokeT' + , stroke, stroke', strokeT, strokeT', strokeLine, strokeLoop + , strokeLocT, strokeLocLine, strokeLocLoop , FillRule(..), fillRule , StrokeOpts(..) @@ -92,7 +95,7 @@ , wedge -- ** General polygons - , polygon, polyVertices + , polygon, polyTrail , PolygonOpts(..), PolyType(..), PolyOrientation(..) -- ** Star polygons @@ -100,6 +103,7 @@ -- ** Regular polygons , regPoly + , triangle , eqTriangle , square , pentagon @@ -191,19 +195,19 @@ ) where -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.Vector -import Diagrams.TwoD.Size -import Diagrams.TwoD.Model -import Diagrams.TwoD.Text -import Diagrams.TwoD.Image +import Diagrams.TwoD.Align +import Diagrams.TwoD.Arc +import Diagrams.TwoD.Combinators +import Diagrams.TwoD.Ellipse +import Diagrams.TwoD.Image +import Diagrams.TwoD.Model +import Diagrams.TwoD.Path +import Diagrams.TwoD.Polygons +import Diagrams.TwoD.Shapes +import Diagrams.TwoD.Size +import Diagrams.TwoD.Text +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector -import Diagrams.Util (tau) +import Diagrams.Util (tau) diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE TypeFamilies - , ViewPatterns - #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Arc @@ -22,18 +21,20 @@ , wedge ) where -import Diagrams.Core - -import Diagrams.Coordinates -import Diagrams.Path -import Diagrams.Segment -import Diagrams.TwoD.Transform -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (unitX, e) -import Diagrams.Util ((#), tau) +import Diagrams.Coordinates +import Diagrams.Core +import Diagrams.Located (at) +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (e, unitX) +import Diagrams.Util (tau, ( # )) -import Data.Semigroup ((<>)) -import Data.VectorSpace((^-^), (*^), negateV) +import Data.Semigroup ((<>)) +import Data.VectorSpace (negateV, (*^), (^-^)) -- For details of this approximation see: -- http://www.tinaja.com/glib/bezcirc2.pdf @@ -42,8 +43,8 @@ -- the positive y direction and sweeps counterclockwise through @s@ -- radians. The approximation is only valid for angles in the first -- quadrant. -bezierFromSweepQ1 :: Rad -> Segment R2 -bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s/2) $ Cubic c2 c1 p0 +bezierFromSweepQ1 :: Rad -> Segment Closed R2 +bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s/2) $ bezier3 c2 c1 p0 where p0@(coords -> x :& y) = rotate (s/2) v c1 = ((4-x)/3) & ((1-x)*(3-x)/(3*y)) c2 = reflectY c1 @@ -55,7 +56,7 @@ -- negative y direction and sweep clockwise. When @s@ is less than -- 0.0001 the empty list results. If the sweep is greater than tau -- then it is truncated to tau. -bezierFromSweep :: Rad -> [Segment R2] +bezierFromSweep :: Rad -> [Segment Closed R2] bezierFromSweep s | s > tau = bezierFromSweep tau | s < 0 = fmap reflectY . bezierFromSweep $ (-s) @@ -89,50 +90,49 @@ arcT :: Angle a => a -> a -> Trail R2 arcT start end | e < s = arcT s (e + fromIntegral d) - | otherwise = Trail bs (sweep >= tau) + | otherwise = (if sweep >= tau then glueTrail else id) + $ trailFromSegments bs where sweep = convertAngle $ end - start bs = map (rotate start) . bezierFromSweep $ sweep - + -- We want to compare the start and the end and in case -- there isn't some law about 'Angle' ordering, we use a -- known 'Angle' for that. - s = convertAngle start :: CircleFrac + s = convertAngle start :: Turn e = convertAngle end d = ceiling (s - e) :: Integer -- | Given a start angle @s@ and an end angle @e@, @'arc' s e@ is the -- path of a radius one arc counterclockwise between the two angles. -- The origin of the arc is its center. -arc :: (Angle a, PathLike p, V p ~ R2) => a -> a -> p -arc start end = pathLike (rotate start $ p2 (1,0)) - False - (trailSegments $ arcT start end) +arc :: (Angle a, TrailLike t, V t ~ R2) => a -> a -> t +arc start end = trailLike $ arcT start end `at` (rotate start $ p2 (1,0)) -- | Like 'arc' but clockwise. -arcCW :: (Angle a, PathLike p, V p ~ R2) => a -> a -> p -arcCW start end = pathLike (rotate start $ p2 (1,0)) - False - -- flipped arguments to get the path we want - -- then reverse the trail to get the cw direction. - (trailSegments . reverseTrail $ arcT end start) +arcCW :: (Angle a, TrailLike t, V t ~ R2) => a -> a -> t +arcCW start end = trailLike $ + -- flipped arguments to get the path we want + -- then reverse the trail to get the cw direction. + (reverseTrail $ arcT end start) + `at` + (rotate start $ p2 (1,0)) -- We could just have `arcCW = reversePath . flip arc` - -- but that wouldn't be `PathLike`. + -- but that wouldn't be `TrailLike`. -- | Given a radus @r@, a start angle @s@ and an end angle @e@, --- @'arc'' r s e@ is the path of a radius @(abs r)@ arc between +-- @'arc'' r s e@ is the path of a radius @(abs r)@ arc between -- the two angles. If a negative radius is given, the arc will --- be clockwise, otherwise it will be counterclockwise. The origin +-- be clockwise, otherwise it will be counterclockwise. The origin -- of the arc is its center. -arc' :: (Angle a, PathLike p, V p ~ R2) => Double -> a -> a -> p -arc' r start end = pathLike (rotate start $ p2 (abs r,0)) - False - (trailSegments . scale (abs r) $ ts) +arc' :: (Angle a, TrailLike p, V p ~ R2) => Double -> a -> a -> p +arc' r start end = trailLike $ scale (abs r) ts `at` (rotate start $ p2 (abs r,0)) where ts | r < 0 = reverseTrail $ arcT end start | otherwise = arcT start end -- | 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)] +wedge :: (Angle a, TrailLike p, V p ~ R2) => Double -> a -> a -> p +wedge r a1 a2 = trailLike . (`at` origin) . wrapLine + $ 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 @@ -1,7 +1,7 @@ -{-# LANGUAGE FlexibleContexts - , TypeFamilies - , ViewPatterns - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Combinators @@ -37,54 +37,57 @@ ) where -import Data.AffineSpace -import Data.Colour -import Data.Default -import Data.Semigroup -import Data.VectorSpace +import Data.AffineSpace +import Data.Colour +import Data.Default.Class +import Data.Semigroup +import Data.VectorSpace -import Diagrams.Core +import Diagrams.Core -import Diagrams.Attributes (lw, fc) -import Diagrams.BoundingBox -import Diagrams.Combinators -import Diagrams.Coordinates -import Diagrams.Path -import Diagrams.Segment -import Diagrams.TwoD.Align -import Diagrams.TwoD.Path () -- for PathLike (D R2) instance -import Diagrams.TwoD.Segment -import Diagrams.TwoD.Shapes -import Diagrams.TwoD.Transform (scaleX, scaleY) -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (unitX, unitY, fromDirection) -import Diagrams.Util ((#)) +import Diagrams.Attributes (fc, lw) +import Diagrams.BoundingBox +import Diagrams.Combinators +import Diagrams.Coordinates +import Diagrams.Path +import Diagrams.Segment +import Diagrams.TrailLike +import Diagrams.TwoD.Align +import Diagrams.TwoD.Path () +import Diagrams.TwoD.Segment +import Diagrams.TwoD.Shapes +import Diagrams.TwoD.Transform (scaleX, scaleY) +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (fromDirection, unitX, unitY) +import Diagrams.Util (( # )) infixl 6 === infixl 6 ||| --- | Place two diagrams (or other objects) vertically --- adjacent to one another, with the first diagram above the second. --- Since Haskell ignores whitespace in expressions, one can thus write +-- | Place two diagrams (or other objects) vertically adjacent to one +-- another, with the first diagram above the second. Since Haskell +-- ignores whitespace in expressions, one can thus write -- --- > c --- > === --- > d +-- @ +-- c +-- === +-- d +-- @ -- -- to place @c@ above @d@. The local origin of the resulting -- combined diagram is the same as the local origin of the first. --- @(===)@ is associative and has 'mempty' as a right (but not left) --- identity. See the documentation of 'beside' for more information. +-- @(===)@ is associative and has 'mempty' as an identity. See the +-- documentation of 'beside' for more information. (===) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a (===) = beside (negateV unitY) -- | Place two diagrams (or other juxtaposable objects) horizontally -- adjacent to one another, with the first diagram to the left of --- the second. The local origin of the resulting --- combined diagram is the same as the local origin of the first. --- @(===)@ is associative and has 'mempty' as a right (but not left) --- identity. See the documentation of 'beside' for more information. +-- the second. The local origin of the resulting combined diagram +-- is the same as the local origin of the first. @(===)@ is +-- associative and has 'mempty' as an identity. See the +-- documentation of 'beside' for more information. (|||) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a (|||) = beside unitX @@ -151,13 +154,13 @@ where seg = FLinear (origin .+^ 0.5 *^ v) (origin .+^ (-0.5) *^ v) --- | @strutX d@ is an empty diagram with width @d@, height 0, and a +-- | @strutX w@ is an empty diagram with width @w@, height 0, and a -- centered local origin. Note that @strutX (-w)@ behaves the same as -- @strutX w@. strutX :: (Backend b R2, Monoid' m) => Double -> QDiagram b R2 m strutX d = strut (d & 0) --- | @strutY d@ is an empty diagram with height @d@, width 0, and a +-- | @strutY h@ is an empty diagram with height @h@, width 0, and a -- centered local origin. Note that @strutY (-h)@ behaves the same as -- @strutY h@. strutY :: (Backend b R2, Monoid' m) => Double -> QDiagram b R2 m @@ -232,10 +235,10 @@ -- | Construct a bounding rectangle for an enveloped object, that is, -- the smallest axis-aligned rectangle which encloses the object. -boundingRect :: ( Enveloped p, Transformable p, PathLike p, V p ~ R2 +boundingRect :: ( Enveloped t, Transformable t, TrailLike t, Monoid t, V t ~ R2 , Enveloped a, V a ~ R2 ) - => a -> p + => a -> t boundingRect = (`boxFit` rect 1 1) . boundingBox -- | \"Set the background color\" of a diagram. That is, place a diff --git a/src/Diagrams/TwoD/Curvature.hs b/src/Diagrams/TwoD/Curvature.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Curvature.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Curvature +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Compute curvature for segments in two dimensions. +-- +----------------------------------------------------------------------------- + +module Diagrams.TwoD.Curvature + ( + curvature + , radiusOfCurvature + , squaredCurvature + , squaredRadiusOfCurvature + ) where + +import Data.AffineSpace +import Data.Monoid.Inf +import Data.VectorSpace + +import Control.Arrow (first, second) +import Control.Monad (join) + +import Diagrams.Core + +import Diagrams.Segment +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector + +-- | Curvature measures how curved the segment is at a point. One intuition +-- for the concept is how much you would turn the wheel when driving a car +-- along the curve. When the wheel is held straight there is zero curvature. +-- When turning a corner to the left we will have positive curvature. When +-- turning to the right we will have negative curvature. +-- +-- Another way to measure this idea is to find the largest circle that we can +-- push up against the curve and have it touch (locally) at exactly the point +-- and not cross the curve. This is a tangent circle. The radius of that +-- circle is the \"Radius of Curvature\" and it is the reciprocal of curvature. +-- Note that if the circle is on the \"left\" of the curve, we have a positive +-- radius, and if it is to the right we have a negative radius. Straight +-- segments have an infinite radius which leads us to our representation. We +-- result in a pair of numerator and denominator so we can include infinity and +-- zero for both the radius and the curvature. +-- +-- +-- Lets consider the following curve: +-- +-- <> +-- +-- The curve starts with positive curvature, +-- +-- <> +-- +-- approaches zero curvature +-- +-- <> +-- +-- then has negative curvature +-- +-- <> +-- +-- > {-# LANGUAGE GADTs #-} +-- > +-- > import Diagrams.TwoD.Curvature +-- > import Data.Monoid.Inf +-- > import Diagrams.Coordinates +-- > +-- > segmentA = Cubic (12 & 0) (8 & 10) (OffsetClosed (20 & 8)) +-- > +-- > curveA = lw 0.1 . stroke . fromSegments $ [segmentA] +-- > +-- > diagramA = pad 1.1 . centerXY $ curveA +-- > +-- > diagramPos = diagramWithRadius 0.2 +-- > +-- > diagramZero = diagramWithRadius 0.5 +-- > +-- > diagramNeg = diagramWithRadius 0.8 +-- > +-- > diagramWithRadius t = pad 1.1 . centerXY +-- > $ curveA +-- > <> showCurvature segmentA t +-- > # withEnvelope (curveA :: D R2) +-- > # lw 0.05 # lc red +-- > +-- > showCurvature bez@(Cubic b c (OffsetClosed d)) t +-- > | v == 0 = mempty +-- > | otherwise = go (radiusOfCurvature bez t) +-- > where +-- > v@(x,y) = unr2 $ firstDerivative b c d t +-- > vp = (-y) & x +-- > +-- > firstDerivative b c d t = let tt = t*t in (3*(3*tt-4*t+1))*^b + (3*(2-3*t)*t)*^c + (3*tt)*^d +-- > +-- > go Infinity = mempty +-- > go (Finite r) = (circle (abs r) # translate vpr +-- > <> stroke (origin ~~ (origin .+^ vpr))) +-- > # moveTo (origin .+^ atParam bez t) +-- > where +-- > vpr = r2 (normalized vp ^* r) +-- > +-- +curvature :: Segment Closed R2 -- ^ Segment to measure on. + -> Double -- ^ Parameter to measure at. + -> PosInf Double -- ^ Result is a @PosInf@ value where @PosInfty@ represents + -- infinite curvature or zero radius of curvature. +curvature s = toPosInf . second sqrt . curvaturePair (fmap unr2 s) -- TODO: Use the generalized unr2 + +-- | With @squaredCurvature@ we can compute values in spaces that do not support +-- 'sqrt' and it is just as useful for relative ordering of curvatures or looking +-- for zeros. +squaredCurvature :: Segment Closed R2 -> Double -> PosInf Double +squaredCurvature s = toPosInf . first (join (*)) . curvaturePair (fmap unr2 s) -- TODO: Use the generalized unr2 + + +-- | Reciprocal of @curvature@. +radiusOfCurvature :: Segment Closed R2 -- ^ Segment to measure on. + -> Double -- ^ Parameter to measure at. + -> PosInf Double -- ^ Result is a @PosInf@ value where @PosInfty@ represents + -- infinite radius of curvature or zero curvature. +radiusOfCurvature s = toPosInf . (\(p,q) -> (q,p)) . second sqrt . curvaturePair (fmap unr2 s) + +-- | Reciprocal of @squaredCurvature@ +squaredRadiusOfCurvature :: Segment Closed R2 -> Double -> PosInf Double +squaredRadiusOfCurvature s = toPosInf . (\(p,q) -> (q,p)) . first (join (*)) . curvaturePair (fmap unr2 s) + + +-- Package up problematic values with the appropriate infinity. +toPosInf :: RealFloat a => (a,a) -> PosInf a +toPosInf (_,0) = Infinity +toPosInf (p,q) + | isInfinite r || isNaN r = Infinity + | otherwise = Finite r + where r = p / q + +-- Internal function that is not quite curvature or squaredCurvature but lets +-- us get there by either taking the square root of the numerator or squaring +-- the denominator respectively. +curvaturePair :: (Num t, Num (Scalar t), VectorSpace t) + => Segment Closed (t, t) -> Scalar t -> (t, t) +curvaturePair (Linear _) t = (0,1) -- Linear segments always have zero curvature (infinite radius). +curvaturePair (Cubic b c (OffsetClosed d)) t = ((x'*y'' - y'*x''), (x'*x' + y'*y')^(3 :: Integer)) + where + (x' ,y' ) = firstDerivative b c d t -- TODO: Use the generalized unr2 + (x'',y'') = secondDerivative b c d t + + firstDerivative b c d t = (3*(3*tt-4*t+1))*^b + (3*(2-3*t)*t)*^c + (3*tt)*^d + where + tt = t * t + + secondDerivative b c d t = (6*(3*t-2))*^b + (6-18*t)*^c + (6*t)*^d + +-- TODO: We should be able to generalize this to higher dimensions. See +-- +-- +-- TODO: I'm not sure what the best way to generalize squaredCurvature to other spaces is. + 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 @@ -1,8 +1,7 @@ -{-# LANGUAGE FlexibleContexts - , TypeSynonymInstances - , MultiParamTypeClasses - , TypeFamilies - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Ellipse @@ -23,28 +22,29 @@ , ellipseXY ) where -import Diagrams.Core - -import Diagrams.TwoD.Types -import Diagrams.TwoD.Transform -import Diagrams.TwoD.Arc +import Diagrams.Core -import Diagrams.Path -import Diagrams.Util +import Diagrams.Located (at) +import Diagrams.Path +import Diagrams.TrailLike +import Diagrams.TwoD.Arc +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types +import Diagrams.Util -- | A circle of radius 1, with center at the origin. -unitCircle :: (PathLike p, V p ~ R2) => p -unitCircle = pathLike (p2 (1,0)) True $ trailSegments (arcT 0 (tau::Rad)) +unitCircle :: (TrailLike t, V t ~ R2) => t +unitCircle = trailLike $ arcT 0 (tau::Rad) `at` (p2 (1,0)) -- | A circle of the given radius, centered at the origin. As a path, -- it begins at (r,0). -circle :: (PathLike p, V p ~ R2, Transformable p) => Double -> p +circle :: (TrailLike t, V t ~ R2, Transformable t) => Double -> t circle d = unitCircle # scale d -- | @ellipse e@ constructs an ellipse with eccentricity @e@ by -- scaling the unit circle in the X direction. The eccentricity must -- be within the interval [0,1). -ellipse :: (PathLike p, V p ~ R2, Transformable p) => Double -> p +ellipse :: (TrailLike t, V t ~ R2, Transformable t) => Double -> t ellipse e | e >= 0 && e < 1 = scaleX (sqrt (1 - e*e)) unitCircle | otherwise = error "Eccentricity of ellipse must be >= 0 and < 1." @@ -52,5 +52,5 @@ -- | @ellipseXY x y@ creates an axis-aligned ellipse, centered at the -- origin, with radius @x@ along the x-axis and radius @y@ along the -- y-axis. -ellipseXY :: (PathLike p, V p ~ R2, Transformable p) => Double -> Double -> p +ellipseXY :: (TrailLike t, V t ~ R2, Transformable t) => Double -> Double -> t ellipseXY x y = unitCircle # scaleX x # scaleY y 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 @@ -43,6 +43,8 @@ instance Transformable Image where transform t1 (Image file sz t2) = Image file sz (t1 <> t2) +instance IsPrim Image + instance HasOrigin Image where moveOriginTo p = translate (origin .-. p) 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 @@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleContexts - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Model @@ -19,29 +19,29 @@ , showLabels ) where -import Diagrams.Core -import Diagrams.Core.Names +import Diagrams.Core +import Diagrams.Core.Names -import Diagrams.Path +import Diagrams.Path -import Diagrams.TwoD.Types -import Diagrams.TwoD.Ellipse -import Diagrams.TwoD.Size (size2D) -import Diagrams.TwoD.Text -import Diagrams.TwoD.Path -import Diagrams.Attributes -import Diagrams.Util +import Diagrams.Attributes +import Diagrams.TwoD.Ellipse +import Diagrams.TwoD.Path +import Diagrams.TwoD.Size (size2D) +import Diagrams.TwoD.Text +import Diagrams.TwoD.Types +import Diagrams.Util -import Control.Arrow (second) -import Data.Semigroup -import Data.Default -import Data.AffineSpace ((.-.)) -import Data.VectorSpace ((^*)) +import Control.Arrow (second) +import Data.AffineSpace ((.-.)) +import Data.Default.Class +import Data.Semigroup +import Data.VectorSpace ((^*)) -import qualified Data.Map as M +import qualified Data.Map as M -import Data.Colour.Names -import Data.Colour (Colour) +import Data.Colour (Colour) +import Data.Colour.Names ------------------------------------------------------------ -- Marking the origin @@ -64,8 +64,8 @@ (w,h) = size2D d ^* oScale oo sz = maximum [w, h, oMinSize oo] -data OriginOpts = OriginOpts { oColor :: Colour Double - , oScale :: Double +data OriginOpts = OriginOpts { oColor :: Colour Double + , oScale :: Double , oMinSize :: Double } diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Offset.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE GADTs #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Offset +-- Copyright : (c) 2012 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Compute offsets to segments in two dimensions. +-- +----------------------------------------------------------------------------- +module Diagrams.TwoD.Offset + ( offsetSegment + ) where + +import Data.AffineSpace +import Data.Monoid.Inf +import Data.VectorSpace + +import Diagrams.Core + +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail +import Diagrams.TwoD.Curvature +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types + +perp :: R2 -> R2 +perp v = rotateBy (-1/4) v + +unitPerp :: R2 -> R2 +unitPerp = normalized . perp + +perpAtParam :: Segment Closed R2 -> Double -> R2 +perpAtParam (Linear (OffsetClosed a)) t = unitPerp a +perpAtParam s@(Cubic _ _ _) t = unitPerp a + where + (Cubic a _ _) = snd $ splitAtParam s t + +-- | Compute the offset of a segment. Given a segment compute the offset +-- curve that is a fixed distance from the original curve. For linear +-- segments nothing special happens, the same linear segment is returned +-- with a point that is offset by a perpendicular vector of the given offset +-- length. +-- +-- Cubic segments require a search for a subdivision of cubic segments that +-- gives an approximation of the offset within the given epsilon tolerance. +-- We must do this because the offset of a cubic is not a cubic itself (the +-- degree of the curve increases). Cubics do, however, approach constant +-- curvature as we subdivide. In light of this we scale the handles of +-- the offset cubic segment in proportion to the radius of curvature difference +-- between the original subsegment and the offset which will have a radius +-- increased by the offset parameter. +-- +-- In the following example the blue lines are the original segments and +-- the alternating green and red lines are the resulting offset trail segments. +-- +-- <> +-- +-- Note that when the original curve has a cusp, the offset curve forms a +-- radius around the cusp, and when there is a loop in the original curve, +-- there can be two cusps in the offset curve. +-- +offsetSegment :: Double -- ^ Epsilon value that represents the maximum + -- allowed deviation from the true offset. In + -- the current implementation each result segment + -- should be bounded by arcs that are plus or + -- minus epsilon from the radius of curvature of + -- the offset. + -> Double -- ^ Offset from the original segment, positive is + -- on the right of the curve, negative is on the + -- left. + -> Segment Closed R2 -- ^ Original segment + -> (Point R2, Trail R2) -- ^ Resulting offset point and trail. +offsetSegment _ r s@(Linear (OffsetClosed a)) = (origin .+^ va, trailFromSegments [s]) + where va = r *^ unitPerp a + +offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = (origin .+^ va, t) + where + t = trailFromSegments (go (radiusOfCurvature s 0.5)) + -- Perpendiculars to handles. + va = r *^ unitPerp a + vc = r *^ unitPerp (c - b) + -- Split segments. + ss = (\(a,b) -> [a,b]) $ splitAtParam s 0.5 + subdivided = concatMap (trailSegments . snd . offsetSegment epsilon r) ss + + -- Offset with handles scaled based on curvature. + offset factor = bezier3 (a^*factor) ((b - c)^*factor + c + vc - va) (c + vc - va) + + -- We observe a corner. Subdivide right away. + go (Finite 0) = subdivided + -- We have some curvature + go roc + | close = [o] + | otherwise = subdivided + where + -- We want the multiplicative factor that takes us from the original + -- segment's radius of curvature roc, to roc + r. + -- + -- r + sr = x * sr + -- + o = offset $ case roc of + Infinity -> 1 -- Do the right thing. + Finite sr -> 1 + r / sr + + close = and [epsilon > (magnitude (p o + va - p s - pp s)) + | t <- [0.25, 0.5, 0.75] + , let p = (`atParam` t) + , let pp = (r *^) . (`perpAtParam` t) + ] + + +-- > import Diagrams.TwoD.Offset +-- > +-- > showExample :: Segment R2 -> Diagram SVG R2 +-- > showExample s = pad 1.1 . centerXY $ d # lc blue # lw 0.1 <> d' # lw 0.1 +-- > where +-- > d = stroke $ Path [(origin, Trail [s] False)] +-- > d' = mconcat . zipWith lc colors . map stroke . uncurry explodeTrail +-- > $ offsetSegment 0.1 (-1) s +-- > +-- > colors = cycle [green, red] +-- > +-- > cubicOffsetExample :: Diagram SVG R2 +-- > cubicOffsetExample = hcat . map showExample $ +-- > [ Cubic (10 & 0) ( 5 & 18) (10 & 20) +-- > , Cubic ( 0 & 20) ( 10 & 10) ( 5 & 10) +-- > , Cubic (10 & 20) ( 0 & 10) (10 & 0) +-- > , Cubic (10 & 20) ((-5) & 10) (10 & 0) +-- > ] 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 @@ -1,10 +1,10 @@ -{-# LANGUAGE FlexibleContexts - , FlexibleInstances - , DeriveDataTypeable - , GeneralizedNewtypeDeriving - , TypeFamilies - , ViewPatterns - #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -23,7 +23,8 @@ module Diagrams.TwoD.Path ( -- * Constructing path-based diagrams - stroke, stroke', strokeT, strokeT' + stroke, stroke', strokeT, strokeT', strokeLine, strokeLoop + , strokeLocT, strokeLocLine, strokeLocLoop -- ** Stroke options @@ -40,24 +41,27 @@ , Clip(..), clipBy ) where -import Control.Applicative (liftA2) -import qualified Data.Foldable as F +import Control.Applicative (liftA2) +import qualified Data.Foldable as F import Data.Semigroup import Data.Typeable import Data.AffineSpace -import Data.Default +import Data.Default.Class import Data.VectorSpace -import Diagrams.Core - import Diagrams.Coordinates +import Diagrams.Core +import Diagrams.Located (Located, mapLoc, unLoc) +import Diagrams.Parametric import Diagrams.Path import Diagrams.Segment import Diagrams.Solve +import Diagrams.Trail +import Diagrams.TrailLike import Diagrams.TwoD.Segment import Diagrams.TwoD.Types -import Diagrams.Util (tau) +import Diagrams.Util (tau) ------------------------------------------------------------ -- Trail and path traces --------------------------------- @@ -68,15 +72,14 @@ -- XXX can the efficiency of this be improved? See the comment in -- Diagrams.Path on the Enveloped instance for Trail. instance Traced (Trail R2) where - getTrace t = case addClosingSegment t of - (Trail segs _) -> - foldr (\seg bds -> moveOriginBy (negateV . segOffset $ seg) bds <> getTrace seg) - mempty - segs + getTrace = withLine $ + foldr + (\seg bds -> moveOriginBy (negateV . atEnd $ seg) bds <> getTrace seg) + mempty + . lineSegments instance Traced (Path R2) where - getTrace = F.foldMap trailTrace . pathTrails - where trailTrace (p, t) = moveOriginTo ((-1) *. p) (getTrace t) + getTrace = F.foldMap getTrace . pathTrails ------------------------------------------------------------ -- Constructing path-based diagrams ---------------------- @@ -96,8 +99,8 @@ => Path R2 -> Diagram b R2 stroke = stroke' (def :: StrokeOpts ()) -instance Renderable (Path R2) b => PathLike (QDiagram b R2 Any) where - pathLike st cl segs = stroke $ pathLike st cl segs +instance Renderable (Path R2) b => TrailLike (QDiagram b R2 Any) where + trailLike = stroke . trailLike -- | A variant of 'stroke' that takes an extra record of options to -- customize its behavior. In particular: @@ -107,8 +110,14 @@ -- 'StrokeOpts' is an instance of 'Default', so @stroke' 'with' { -- ... }@ syntax may be used. stroke' :: (Renderable (Path R2) b, IsName a) => StrokeOpts a -> Path R2 -> Diagram b R2 -stroke' opts p - = mkQD (Prim p) +stroke' opts path + | null (pathTrails p1) = mkP p2 + | null (pathTrails p2) = mkP p1 + | otherwise = mkP p1 <> mkP p2 + where + (p1,p2) = partitionPath (isLine . unLoc) path + mkP p + = mkQD (Prim p) (getEnvelope p) (getTrace p) (fromNames . concat $ @@ -121,7 +130,7 @@ -- records can be created using @'with' { ... }@ notation. data StrokeOpts a = StrokeOpts - { vertexNames :: [[a]] -- ^ Atomic names that should be assigned + { vertexNames :: [[a]] -- ^ Atomic names that should be assigned -- to the vertices of the path so that -- they can be referenced later. If -- there are not enough names, the extra @@ -172,6 +181,31 @@ => StrokeOpts a -> Trail R2 -> Diagram b R2 strokeT' opts = stroke' opts . pathFromTrail +-- | A composition of 'strokeT' and 'wrapLine' for conveniently +-- converting a line directly into a diagram. +strokeLine :: (Renderable (Path R2) b) => Trail' Line R2 -> Diagram b R2 +strokeLine = strokeT . wrapLine + +-- | A composition of 'strokeT' and 'wrapLoop' for conveniently +-- converting a loop directly into a diagram. +strokeLoop :: (Renderable (Path R2) b) => Trail' Loop R2 -> Diagram b R2 +strokeLoop = strokeT . wrapLoop + +-- | A convenience function for converting a @Located Trail@ directly +-- into a diagram; @strokeLocT = stroke . trailLike@. +strokeLocT :: (Renderable (Path R2) b) => Located (Trail R2) -> Diagram b R2 +strokeLocT = stroke . trailLike + +-- | A convenience function for converting a @Located@ line directly +-- into a diagram; @strokeLocLine = stroke . trailLike . mapLoc wrapLine@. +strokeLocLine :: (Renderable (Path R2) b) => Located (Trail' Line R2) -> Diagram b R2 +strokeLocLine = stroke . trailLike . mapLoc wrapLine + +-- | A convenience function for converting a @Located@ loop directly +-- into a diagram; @strokeLocLoop = stroke . trailLike . mapLoc wrapLoop@. +strokeLocLoop :: (Renderable (Path R2) b) => Located (Trail' Loop R2) -> Diagram b R2 +strokeLocLoop = stroke . trailLike . mapLoc wrapLoop + ------------------------------------------------------------ -- Inside/outside testing ------------------------------------------------------------ @@ -233,13 +267,13 @@ -- | Compute the sum of signed crossings of a trail starting from the -- given point in the positive x direction. -trailCrossings :: P2 -> (P2, Trail R2) -> Int +trailCrossings :: P2 -> Located (Trail R2) -> Int - -- open trails have no inside or outside, so don't contribute crossings -trailCrossings _ (_, t) | not (isClosed t) = 0 + -- non-loop trails have no inside or outside, so don't contribute crossings +trailCrossings _ t | not (isLoop (unLoc t)) = 0 -trailCrossings p@(unp2 -> (x,y)) (start, tr) - = sum . map test $ fixTrail start tr +trailCrossings p@(unp2 -> (x,y)) tr + = sum . map test $ fixTrail tr where test (FLinear a@(unp2 -> (_,ay)) b@(unp2 -> (_,by))) | ay <= y && by > y && isLeft a b > 0 = 1 @@ -257,7 +291,7 @@ ( 3*x1y - 6*c1y + 3*c2y) (-3*x1y + 3*c1y) (x1y - y) - testT t = let (unp2 -> (px,_)) = c `fAtParam` t + testT t = let (unp2 -> (px,_)) = c `atParam` 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) diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE TypeFamilies - , ScopedTypeVariables - , DeriveFunctor - , ExistentialQuantification - , ViewPatterns - #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -22,15 +21,15 @@ PolyType(..) , PolyOrientation(..) , PolygonOpts(..) - , polyVertices , polygon + , polyTrail -- ** Generating polygon vertices - , polyPolarVs - , polySidesVs, polySidesVs' - , polyRegularVs + , polyPolarTrail + , polySidesTrail + , polyRegularTrail , orient @@ -45,28 +44,33 @@ ) where -import Data.Ord (comparing) -import Data.List (maximumBy) -import Data.Maybe (catMaybes) -import Data.Monoid (mconcat) - -import Control.Monad (forM, liftM) - -import Control.Monad.ST (runST, ST) -import Data.Array.ST (STUArray, newArray, readArray, writeArray) - -import Data.AffineSpace ((.-.), (.+^)) -import Data.VectorSpace (magnitude, normalized, project, (<.>), (^*)) -import Data.Default +import Control.Monad (forM, liftM) +import Control.Monad.ST (ST, runST) +import Data.Array.ST (STUArray, newArray, readArray, + writeArray) +import qualified Data.Foldable as F +import Data.List (maximumBy, minimumBy) +import qualified Data.List.NonEmpty as NEL +import Data.Maybe (catMaybes) +import Data.Monoid (mconcat, mempty) +import Data.Ord (comparing) -import Diagrams.Core +import Data.AffineSpace ((.+^), (.-.)) +import Data.Default.Class +import Data.VectorSpace (magnitude, normalized, project, (<.>), + (^*)) -import Diagrams.TwoD.Types -import Diagrams.TwoD.Transform -import Diagrams.TwoD.Vector (unitX, unitY, unit_Y) -import Diagrams.Path -import Diagrams.Points (centroid) -import Diagrams.Util ((#), tau) +import Diagrams.Core +import Diagrams.Located +import Diagrams.Path +import Diagrams.Points (centroid) +import Diagrams.Segment +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y) +import Diagrams.Util (tau, ( # )) -- | Method used to determine the vertices of a polygon. data PolyType = forall a. Angle a => PolyPolar [a] [Double] @@ -134,15 +138,15 @@ -- | Options for specifying a polygon. data PolygonOpts = PolygonOpts - { polyType :: PolyType + { polyType :: PolyType -- ^ Specification for the polygon's vertices. - , polyOrient :: PolyOrientation + , polyOrient :: PolyOrientation -- ^ Should a rotation be applied to the -- polygon in order to orient it in a -- particular way? - , polyCenter :: P2 + , polyCenter :: P2 -- ^ Should a translation be applied to the -- polygon in order to place the center at a -- particular location? @@ -153,74 +157,81 @@ 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 +-- | Generate a polygon. See 'PolygonOpts' for more information. +polyTrail :: PolygonOpts -> Located (Trail R2) +polyTrail po = transform ori tr where - ps = case polyType po of - PolyPolar ans szs -> polyPolarVs ans szs - PolySides ans szs -> polySidesVs ans szs - PolyRegular n r -> polyRegularVs n r + tr = case polyType po of + PolyPolar ans szs -> polyPolarTrail ans szs + PolySides ans szs -> polySidesTrail ans szs + PolyRegular n r -> polyRegularTrail n r ori = case polyOrient po of - OrientH -> orient unit_Y ps - OrientV -> orient unitX ps - OrientTo v -> orient v ps - NoOrient -> ps + OrientH -> orient unit_Y tr + OrientV -> orient unitX tr + OrientTo v -> orient v tr + NoOrient -> mempty -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 polygon described by the given options. +polygon :: (TrailLike t, V t ~ R2) => PolygonOpts -> t +polygon = trailLike . polyTrail --- | Generate the vertices of a polygon specified by polar data +-- | Generate the located trail 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 -> rotate a . scale l $ p2 (1,0)) - (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) +polyPolarTrail :: Angle a => [a] -> [Double] -> Located (Trail R2) +polyPolarTrail [] _ = emptyTrail `at` origin +polyPolarTrail _ [] = emptyTrail `at` origin +polyPolarTrail ans (r:rs) = tr `at` p1 where - ans' = scanl (+) 0 ans + p1 = p2 (1,0) # scale r + tr = closeTrail . trailFromVertices $ + zipWith + (\a l -> rotate a . scale l $ p2 (1,0)) + (scanl (+) 0 ans) + (r:rs) -- | 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 +-- angles, and a starting point for the trail such that the origin +-- is at the centroid of the vertices. See 'PolySides'. +polySidesTrail :: Angle a => [a] -> [Double] -> Located (Trail R2) +polySidesTrail ans ls = tr `at` (centroid ps # scale (-1)) + where + ans' = scanl (+) 0 ans + offsets = zipWith rotate ans' (map (unitY ^*) ls) + ps = scanl (.+^) origin offsets + tr = closeTrail . trailFromOffsets $ offsets -- | 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) +polyRegularTrail :: Int -> Double -> Located (Trail R2) +polyRegularTrail n r = polyPolarTrail + (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 ((.-. origin) -> p) = signum (w <.> p) * magnitude (project w p) - x' = maximumBy (comparing (distAlong v)) [n1, n2] - e = x' .-. x - th = Rad $ acos ((e <.> normalized v) / magnitude e) - a | rightTurn (x .+^ v) x x' = tau/4 - th - | otherwise = th - tau/4 - sndOf3 (_,b,_) = b - rightTurn (unp2 -> (x1,y1)) (unp2 -> (x2, y2)) (unp2 -> (x3,y3)) = - (x2 - x1)*(y3 - y1) - (y2 - y1)*(x3-x1) < 0 +-- | Generate a transformation to orient a trail. @orient v t@ +-- generates the smallest rotation such that one of the segments +-- adjacent to the vertex furthest in the direction of @v@ is +-- perpendicular to @v@. +orient :: R2 -> Located (Trail R2) -> T2 +orient v = orientPoints v . trailVertices +orientPoints :: R2 -> [P2] -> T2 +orientPoints v xs = rotation a + where + (n1,x,n2) = maximumBy (comparing (distAlong v . sndOf3)) + (zip3 (tail (cycle xs)) xs (last xs : init xs)) + distAlong w ((.-. origin) -> p) = signum (w <.> p) * magnitude (project w p) + sndOf3 (_,x,_) = x + a = minimumBy (comparing abs) . map (angleFromNormal . (.-. x)) $ [n1,n2] + v' = normalized v + angleFromNormal o + | leftTurn o' v' = phi + | otherwise = negate phi + where + o' = normalized o + theta = acos (v' <.> o') + phi + | theta <= tau/4 = Rad $ tau/4 - theta + | otherwise = Rad $ theta - tau/4 + ------------------------------------------------------------ -- Function graphs ------------------------------------------------------------ @@ -299,9 +310,9 @@ -- 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 like, since a list of vertices is 'TrailLike'. 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 +-- returned (instead of any 'TrailLike') 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 @@ -310,5 +321,10 @@ StarFun g -> g StarSkip k -> (+k) graphToPath = mconcat . map partToPath - partToPath (Cycle ps) = close $ fromVertices ps + + partToPath (Cycle ps) = pathFromLocTrail + . mapLoc closeTrail + . fromVertices + $ ps + partToPath (Hair ps) = fromVertices ps diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE FlexibleContexts - , FlexibleInstances - , UndecidableInstances - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -17,24 +16,26 @@ module Diagrams.TwoD.Segment where -import Control.Applicative (liftA2) +import Control.Applicative (liftA2) -import Data.AffineSpace -import Data.Monoid.PosInf hiding (minimum) -import Data.VectorSpace +import Data.AffineSpace +import Data.Monoid.Inf hiding (minimum) +import Data.VectorSpace -import Diagrams.Core -import Diagrams.Core.Trace +import Diagrams.Core +import Diagrams.Core.Trace -import Diagrams.Segment -import Diagrams.Solve -import Diagrams.TwoD.Transform -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector -import Diagrams.Util +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Segment +import Diagrams.Solve +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector +import Diagrams.Util -instance Traced (Segment R2) where - getTrace = getTrace . mkFixedSeg origin +instance Traced (Segment Closed R2) where + getTrace = getTrace . mkFixedSeg . (`at` origin) instance Traced (FixedSegment R2) where @@ -69,7 +70,7 @@ t1 = (perp v0 <.> p) / det in if det == 0 || t0 < 0 || t0 > 1 - then PosInfty + then Infinity else Finite t1 {- To do intersection of a line with a cubic Bezier, we first rotate @@ -94,9 +95,9 @@ c = -3*y0 + 3*y1 d = y0 ts = filter (liftA2 (&&) (>= 0) (<= 1)) (cubForm a b c d) - xs = map (fst . unp2 . fAtParam bez') ts + xs = map (fst . unp2 . atParam bez') ts in case xs of - [] -> PosInfty + [] -> Infinity _ -> Finite (minimum xs) 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,7 +1,5 @@ -{-# LANGUAGE TypeFamilies - , FlexibleContexts - , ViewPatterns - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -22,6 +20,7 @@ -- * Regular polygons , regPoly + , triangle , eqTriangle , square , pentagon @@ -44,45 +43,88 @@ , roundedRect' ) where -import Diagrams.Core +import Diagrams.Core -import Diagrams.Coordinates -import Diagrams.Path -import Diagrams.Segment -import Diagrams.TwoD.Arc -import Diagrams.TwoD.Polygons -import Diagrams.TwoD.Transform -import Diagrams.TwoD.Types +import Diagrams.Coordinates +import Diagrams.Located (at) +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.TwoD.Arc +import Diagrams.TwoD.Polygons +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types -import Diagrams.Util +import Diagrams.Util -import Data.Default -import Data.Semigroup +import Data.Default.Class +import Data.Semigroup -- | Create a centered horizontal (L-R) line of the given length. -hrule :: (PathLike p, V p ~ R2) => Double -> p -hrule d = pathLike (p2 (-d/2,0)) False [Linear (d & 0)] +-- +-- <> +-- +-- > hruleEx = vcat' with {sep = 0.2} (map hrule [1..5]) +-- > # centerXY # pad 1.1 +hrule :: (TrailLike t, V t ~ R2) => Double -> t +hrule d = trailLike $ trailFromSegments [straight (d & 0)] `at` (p2 (-d/2,0)) -- | Create a centered vertical (T-B) line of the given length. -vrule :: (PathLike p, V p ~ R2) => Double -> p -vrule d = pathLike (p2 (0,d/2)) False [Linear (0 & (-d))] +-- +-- <> +-- +-- > vruleEx = hcat' with {sep = 0.2} (map vrule [1, 1.2 .. 2]) +-- > # centerXY # pad 1.1 +vrule :: (TrailLike t, V t ~ R2) => Double -> t +vrule d = trailLike $ trailFromSegments [straight (0 & (-d))] `at` (p2 (0,d/2)) -- | A square with its center at the origin and sides of length 1, -- oriented parallel to the axes. -unitSquare :: (PathLike p, V p ~ R2) => p +-- +-- <> +unitSquare :: (TrailLike t, V t ~ R2) => t unitSquare = polygon with { polyType = PolyRegular 4 (sqrt 2 / 2) , polyOrient = OrientH } +-- > unitSquareEx = unitSquare # pad 1.1 # showOrigin + -- | A square with its center at the origin and sides of the given -- length, oriented parallel to the axes. -square :: (PathLike p, Transformable p, V p ~ R2) => Double -> p -square d = unitSquare # scale d +-- +-- <> +square :: (TrailLike t, Transformable t, V t ~ R2) => Double -> t +square d = rect d d +-- > squareEx = hcat' with {sep = 0.5} [square 1, square 2, square 3] +-- > # centerXY # pad 1.1 # lw 0.03 + -- | @rect w h@ is an axis-aligned rectangle of width @w@ and height -- @h@, centered at the origin. -rect :: (PathLike p, Transformable p, V p ~ R2) => Double -> Double -> p -rect w h = unitSquare # scaleX w # scaleY h +-- +-- <> +rect :: (TrailLike t, Transformable t, V t ~ R2) => Double -> Double -> t +rect w h = trailLike . head . pathTrails $ unitSquare # scaleX w # scaleY h +-- > rectEx = rect 1 0.7 # pad 1.1 + + -- The above may seem a bit roundabout. In fact, we used to have + -- + -- rect w h = unitSquare # scaleX w # scaleY h + -- + -- since unitSquare can produce any TrailLike. The current code + -- instead uses (unitSquare # scaleX w # scaleY h) to specifically + -- produce a Path, which is then deconstructed and passed back into + -- 'trailLike' to create any TrailLike. + -- + -- The difference is that while scaling by zero works fine for + -- Path it does not work very well for, say, Diagrams (leading to + -- NaNs or worse). This way, we force the scaling to happen on a + -- Path, where we know it will behave properly, and then use the + -- resulting geometry to construct an arbitrary TrailLike. + -- + -- See https://github.com/diagrams/diagrams-lib/issues/43 . + ------------------------------------------------------------ -- Regular polygons ------------------------------------------------------------ @@ -93,57 +135,90 @@ -- 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 :: (TrailLike t, V t ~ R2) => Int -> Double -> t regPoly n l = polygon with { polyType = PolySides - (repeat (1/ fromIntegral n :: CircleFrac)) + (repeat (1/ fromIntegral n :: Turn)) (replicate (n-1) l) , polyOrient = OrientH } --- | 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 +-- > shapeEx sh = sh 1 # pad 1.1 +-- > triangleEx = shapeEx triangle +-- > pentagonEx = shapeEx pentagon +-- > hexagonEx = shapeEx hexagon +-- > septagonEx = shapeEx septagon +-- > octagonEx = shapeEx octagon +-- > nonagonEx = shapeEx nonagon +-- > decagonEx = shapeEx decagon +-- > hendecagonEx = shapeEx hendecagon +-- > dodecagonEx = shapeEx dodecagon +-- | A synonym for 'triangle', provided for backwards compatibility. +eqTriangle :: (TrailLike t, V t ~ R2) => Double -> t +eqTriangle = triangle + +-- | An equilateral triangle, with sides of the given length and base +-- parallel to the x-axis. +-- +-- <> +triangle :: (TrailLike t, V t ~ R2) => Double -> t +triangle = regPoly 3 + -- | 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 :: (TrailLike t, V t ~ R2) => Double -> t pentagon = regPoly 5 -- | 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 :: (TrailLike t, V t ~ R2) => Double -> t hexagon = regPoly 6 -- | 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 :: (TrailLike t, V t ~ R2) => Double -> t septagon = regPoly 7 -- | 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 :: (TrailLike t, V t ~ R2) => Double -> t octagon = regPoly 8 -- | 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 :: (TrailLike t, V t ~ R2) => Double -> t nonagon = regPoly 9 -- | 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 :: (TrailLike t, V t ~ R2) => Double -> t 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 :: (TrailLike t, V t ~ R2) => Double -> t 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 :: (TrailLike t, V t ~ R2) => Double -> t dodecagon = regPoly 12 ------------------------------------------------------------ @@ -159,8 +234,19 @@ -- the corners from overlapping. The trail or path begins with the -- right edge and proceeds counterclockwise. If you need to specify -- a different radius for each corner individually, use --- @roundedRect'@ instead. -roundedRect :: (PathLike p, V p ~ R2) => Double -> Double -> Double -> p +-- 'roundedRect'' instead. +-- +-- <> +-- +-- > roundedRectEx = pad 1.1 . centerXY $ hcat' with { sep = 0.2 } +-- > [ roundedRect 0.5 0.4 0.1 +-- > , roundedRect 0.5 0.4 (-0.1) +-- > , roundedRect' 0.7 0.4 with { radiusTL = 0.2 +-- > , radiusTR = -0.2 +-- > , radiusBR = 0.1 } +-- > ] + +roundedRect :: (TrailLike t, V t ~ R2) => Double -> Double -> Double -> t roundedRect w h r = roundedRect' w h (with { radiusTL = r, radiusBR = r, radiusTR = r, @@ -170,10 +256,12 @@ -- each corner indivually, using @RoundedRectOpts@. The default corner radius is 0. -- Each radius can also be negative, which results in the curves being reversed -- to be inward instead of outward. -roundedRect' :: (PathLike p, V p ~ R2) => Double -> Double -> RoundedRectOpts -> p +roundedRect' :: (TrailLike t, V t ~ R2) => Double -> Double -> RoundedRectOpts -> t roundedRect' w h opts - = pathLike (p2 (w/2, abs rBR - h/2)) True - . trailSegments + = trailLike + . (`at` (p2 (w/2, abs rBR - h/2))) + . wrapTrail + . glueLine $ seg (0, h - abs rTR - abs rBR) <> mkCorner 0 rTR <> seg (abs rTR + abs rTL - w, 0) @@ -182,7 +270,7 @@ <> mkCorner 2 rBL <> seg (w - abs rBL - abs rBR, 0) <> mkCorner 3 rBR - where seg = fromOffsets . (:[]) . r2 + where seg = lineFromOffsets . (:[]) . r2 diag = sqrt (w * w + h * h) -- to clamp corner radius, need to compare with other corners that share an -- edge. If the corners overlap then reduce the largest corner first, as far @@ -205,7 +293,7 @@ mkCorner k r | r == 0 = mempty | r < 0 = doArc 3 2 | otherwise = doArc 0 1 - where doArc d d' = arc' r ((k+d)/4) ((k+d')/4:: CircleFrac) + where doArc d d' = arc' r ((k+d)/4) ((k+d')/4:: Turn) data RoundedRectOpts = RoundedRectOpts { radiusTL :: Double , radiusTR :: Double diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE FlexibleContexts - , TypeFamilies - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Size @@ -28,12 +27,12 @@ , sized, sizedAs ) where -import Diagrams.Core -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector +import Diagrams.Core +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector -import Control.Arrow ((***), (&&&)) -import Control.Applicative ((<$>), liftA2) +import Control.Applicative (liftA2, (<$>)) +import Control.Arrow ((&&&), (***)) ------------------------------------------------------------ -- Computing diagram sizes @@ -92,6 +91,7 @@ | Absolute -- ^ Absolute size: use whatever -- size an object already has; -- do not rescale. + deriving (Eq, Ord, Show) -- | Create a size specification from a possibly-specified width and -- height. 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 @@ -58,6 +58,8 @@ instance Transformable Text where transform t (Text tt a s) = Text (t <> tt) a s +instance IsPrim Text + instance HasOrigin Text where moveOriginTo p = translate (origin .-. p) @@ -68,12 +70,34 @@ data TextAlignment = BaselineText | BoxAlignedText Double Double mkText :: Renderable Text b => TextAlignment -> String -> Diagram b R2 -mkText a t = recommendFillColor black +mkText a t = recommendFillColor black -- See Note [recommendFillColor] $ mkQD (Prim (Text mempty a t)) mempty mempty mempty mempty + +-- ~~~~ Note [recommendFillColor] + +-- The reason we "recommend" a fill color of black instead of setting +-- it directly (or instead of simply not specifying a fill color at +-- all) was originally to support the SVG backend, though it is +-- actually in some sense the "right thing" to do, and other backends +-- we add later may conceivably need it as well. The cairo backend +-- defaults happen to be to use a transparent fill for paths and a +-- black fill for text. The SVG standard, however, specifies a +-- default fill of black for everything (both text and paths). In +-- order to correctly render paths with no fill set, the SVG backend +-- must therefore explicitly set the fill to transparent -- but this +-- meant that it was also drawing text with a transparent fill. The +-- solution is that we now explicitly inform all backends that the +-- *default* ("recommended") fill color for text should be black; an +-- absence of fill specification now consistently means to use a +-- "transparent" fill no matter what the primitive. The reason we +-- need the special recommend/commit distinction is because if the +-- user explicitly sets a fill color later it should override this +-- recommendation; normally, the innermost occurrence of an attribute +-- would override all outer occurrences. -- | Create a primitive text diagram from the given string, with center -- alignment, equivalent to @'alignedText' 0.5 0.5@. diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE FlexibleContexts - , FlexibleInstances - , TypeFamilies - , ViewPatterns - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Transform @@ -46,25 +46,28 @@ , shearingY, shearY -- * Scale invariance - , ScaleInv(..), scaleInv + , ScaleInv(..), scaleInv, scaleInvPrim + -- * component-wise + , onBasis ) where -import Diagrams.Core +import Diagrams.Core +import qualified Diagrams.Core.Transform as T -import Control.Newtype (over) +import Control.Newtype (over) -import Diagrams.Coordinates -import Diagrams.Transform -import Diagrams.TwoD.Size (width, height) -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (direction) +import Diagrams.Coordinates +import Diagrams.Transform +import Diagrams.TwoD.Size (height, width) +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (direction) -import Data.Semigroup +import Data.Semigroup -import Data.AffineSpace +import Data.AffineSpace -import Control.Arrow (first, second) +import Control.Arrow (first, second) -- Rotation ------------------------------------------------ @@ -81,7 +84,7 @@ -- 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 (tau\/4 :: 'Rad')@, and @rotate (90 :: +-- 'Turn')@, @rotate (tau\/4 :: 'Rad')@, and @rotate (90 :: -- 'Deg')@ all represent the same transformation, namely, a -- counterclockwise rotation by a right angle. To rotate about some -- point other than the local origin, see 'rotateAbout'. @@ -89,14 +92,14 @@ -- 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. +-- 'rotateBy', which is specialized to take a 'Turn' argument. rotate :: (Transformable t, V t ~ R2, Angle a) => a -> t -> t rotate = transform . rotation -- | 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 :: (Transformable t, V t ~ R2) => CircleFrac -> t -> t +-- @Turn@ arguments; it can be more convenient to write +-- @rotateBy (1\/4)@ than @'rotate' (1\/4 :: 'Turn')@. +rotateBy :: (Transformable t, V t ~ R2) => Turn -> t -> t rotateBy = transform . rotation -- | @rotationAbout p@ is a rotation about the point @p@ (instead of @@ -248,9 +251,6 @@ -- Scale invariance ---------------------------------------- --- XXX what about freezing? Doesn't interact with ScaleInv the way it --- ought. - -- | The @ScaleInv@ wrapper creates two-dimensional /scale-invariant/ -- objects. Intuitively, a scale-invariant object is affected by -- transformations like translations and rotations, but not by scales. @@ -284,13 +284,14 @@ data ScaleInv t = ScaleInv - { unScaleInv :: t + { unScaleInv :: t , scaleInvDir :: R2 , scaleInvLoc :: P2 } deriving (Show) --- | Create a scale-invariant object pointing in the given direction. +-- | Create a scale-invariant object pointing in the given direction, +-- located at the origin. scaleInv :: t -> R2 -> ScaleInv t scaleInv t d = ScaleInv t d origin @@ -304,7 +305,54 @@ where angle :: Rad angle = direction (transform tr v) - direction v - rot :: ( Transformable t, (V t ~ R2) ) => t -> t + rot :: (Transformable t, V t ~ R2) => t -> t rot = rotateAbout l angle l' = transform tr l trans = translate (l' .-. l) + +-- This is how we handle freezing properly with ScaleInv wrappers. +-- Normal transformations are applied ignoring scaling; "frozen" +-- transformations (i.e. transformations applied after a freeze) are +-- applied directly to the underlying object, scales and all. We must +-- take care to transform the reference point and direction vector +-- appropriately. +instance (V t ~ R2, Transformable t) => IsPrim (ScaleInv t) where + transformWithFreeze t1 t2 s = ScaleInv t'' d'' origin'' + where + -- first, apply t2 normally, i.e. ignoring scaling + s'@(ScaleInv t' _ _) = transform t2 s + + -- now apply t1 to get the new direction and origin + (ScaleInv _ d'' origin'') = transform t1 s' + + -- but apply t1 directly to the underlying thing, scales and all. + t'' = transform t1 t' + +instance (Renderable t b, V t ~ R2) => Renderable (ScaleInv t) b where + render b = render b . unScaleInv + +-- | Create a diagram from a single scale-invariant primitive. The +-- vector argument specifies the direction in which the primitive is +-- \"pointing\" (for the purpose of keeping it rotated correctly +-- under non-uniform scaling). The primitive is assumed to be +-- \"located\" at the origin (for the purpose of translating it +-- correctly under scaling). +-- +-- Note that the resulting diagram will have an /empty/ envelope, +-- trace, and query. The reason is that the envelope, trace, and +-- query cannot be cached---applying a transformation would cause +-- the cached envelope, etc. to get \"out of sync\" with the +-- scale-invariant object. The intention, at any rate, is that +-- scale-invariant things will be used only as \"decorations\" (/e.g./ +-- arrowheads) which should not affect the envelope, trace, and +-- query. +scaleInvPrim :: (Transformable t, Renderable t b, V t ~ R2, Monoid m) + => t -> R2 -> QDiagram b R2 m +scaleInvPrim t d = mkQD (Prim $ scaleInv t d) mempty mempty mempty mempty + +-- | Get the matrix equivalent of the linear transform, +-- (as a pair of columns) and the translation vector. This +-- is mostly useful for implementing backends. +onBasis :: Transformation R2 -> ((R2, R2), R2) +onBasis t = ((x, y), v) + where ((x:y:[]), v) = T.onBasis t 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,11 +1,11 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -27,21 +27,21 @@ -- * Angles , Angle(..) - , CircleFrac(..), Rad(..), Deg(..) + , Turn(..), CircleFrac, Rad(..), Deg(..) , fullCircle, convertAngle ) where -import Diagrams.Coordinates -import Diagrams.Util (tau) -import Diagrams.Core +import Diagrams.Coordinates +import Diagrams.Core +import Diagrams.Util (tau) -import Control.Newtype +import Control.Newtype -import Data.Basis -import Data.NumInstances () -import Data.VectorSpace +import Data.Basis +import Data.NumInstances.Tuple () +import Data.VectorSpace -import Data.Typeable +import Data.Typeable ------------------------------------------------------------ -- 2D Euclidean space @@ -51,9 +51,14 @@ -- -- * To construct a vector, use 'r2', or '&' (from "Diagrams.Coordinates"): -- --- > r2 (3,4) :: R2 --- > 3 & 4 :: R2 +-- @ +-- r2 (3,4) :: R2 +-- 3 & 4 :: R2 +-- @ -- +-- Note that "Diagrams.Coordinates" is not re-exported by +-- "Diagrams.Prelude" and must be explicitly imported. +-- -- * To construct the vector from the origin to a point @p@, use -- @p 'Data.AffineSpace..-.' 'origin'@. -- @@ -64,8 +69,10 @@ -- or 'coords' (from "Diagrams.Coordinates"). These are typically -- used in conjunction with the @ViewPatterns@ extension: -- --- > foo (unr2 -> (x,y)) = ... --- > foo (coords -> x :& y) = ... +-- @ +-- foo (unr2 -> (x,y)) = ... +-- foo (coords -> x :& y) = ... +-- @ newtype R2 = R2 { unR2 :: (Double, Double) } deriving (AdditiveGroup, Eq, Ord, Typeable, Num, Fractional) @@ -129,8 +136,10 @@ -- * To construct a point, use 'p2', or '&' (see -- "Diagrams.Coordinates"): -- --- > p2 (3,4) :: P2 --- > 3 & 4 :: P2 +-- @ +-- p2 (3,4) :: P2 +-- 3 & 4 :: P2 +-- @ -- -- * To construct a point from a vector @v@, use @'origin' 'Data.AffineSpace..+^' v@. -- @@ -141,8 +150,10 @@ -- or 'coords' (from "Diagrams.Coordinates"). It's common to use -- these in conjunction with the @ViewPatterns@ extension: -- --- > foo (unp2 -> (x,y)) = ... --- > foo (coords -> x :& y) = ... +-- @ +-- foo (unp2 -> (x,y)) = ... +-- foo (coords -> x :& y) = ... +-- @ type P2 = Point R2 -- | Construct a 2D point from a pair of coordinates. See also '&'. @@ -163,10 +174,13 @@ -- Angles -- | Newtype wrapper used to represent angles as fractions of a --- circle. For example, 1\/3 = tau\/3 radians = 120 degrees. -newtype CircleFrac = CircleFrac { getCircleFrac :: Double } +-- circle. For example, 1\/3 turn = tau\/3 radians = 120 degrees. +newtype Turn = Turn { getTurn :: Double } deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac) +-- | Deprecated synonym for 'Turn', retained for backwards compatibility. +type CircleFrac = Turn + -- | Newtype wrapper for representing angles in radians. newtype Rad = Rad { getRad :: Double } deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac) @@ -177,30 +191,34 @@ -- | Type class for types that measure angles. class Num a => Angle a where - -- | Convert to a fraction of a circle. - toCircleFrac :: a -> CircleFrac + -- | Convert to a turn, /i.e./ a fraction of a circle. + toTurn :: a -> Turn - -- | Convert from a fraction of a circle. - fromCircleFrac :: CircleFrac -> a + -- | Convert from a turn, /i.e./ a fraction of a circle. + fromTurn :: Turn -> a -instance Angle CircleFrac where - toCircleFrac = id - fromCircleFrac = id +instance Angle Turn where + toTurn = id + fromTurn = id --- | tau radians = 1 full circle. +-- | tau radians = 1 full turn. instance Angle Rad where - toCircleFrac = CircleFrac . (/tau) . getRad - fromCircleFrac = Rad . (*tau) . getCircleFrac + toTurn = Turn . (/tau) . getRad + fromTurn = Rad . (*tau) . getTurn --- | 360 degrees = 1 full circle. +-- | 360 degrees = 1 full turn. instance Angle Deg where - toCircleFrac = CircleFrac . (/360) . getDeg - fromCircleFrac = Deg . (*360) . getCircleFrac + toTurn = Turn . (/360) . getDeg + fromTurn = Deg . (*360) . getTurn --- | An angle representing a full circle. +-- | An angle representing one full turn. +fullTurn :: Angle a => a +fullTurn = fromTurn 1 + +-- | Deprecated synonym for 'fullTurn', retained for backwards compatibility. fullCircle :: Angle a => a -fullCircle = fromCircleFrac 1 +fullCircle = fullTurn -- | Convert between two angle representations. convertAngle :: (Angle a, Angle b) => a -> b -convertAngle = fromCircleFrac . toCircleFrac +convertAngle = fromTurn . toTurn diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE FlexibleContexts - , TypeFamilies - , ViewPatterns - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Vector @@ -18,10 +17,15 @@ -- * Converting between vectors and angles , direction, fromDirection, e + + -- * 2D vector utilities + , perp, leftTurn ) where -import Diagrams.Coordinates -import Diagrams.TwoD.Types +import Data.VectorSpace ((<.>)) +import Diagrams.Coordinates +import Diagrams.TwoD.Types +import Diagrams.Util (( # )) -- | The unit vector in the positive X direction. unitX :: R2 @@ -53,3 +57,14 @@ -- | A convenient synonym for 'fromDirection'. e :: Angle a => a -> R2 e = fromDirection + +-- | @perp v@ is perpendicular to and has the same magnitude as @v@. +-- In particular @perp v == rotateBy (1/4) v@. +perp :: R2 -> R2 +perp (coords -> x :& y) = (-y) & x + +-- | @leftTurn v1 v2@ tests whether the direction of @v2@ is a left +-- turn from @v1@ (that is, if the direction of @v2@ can be obtained +-- from that of @v1@ by adding an angle 0 <= theta <= tau/2). +leftTurn :: R2 -> R2 -> Bool +leftTurn v1 v2 = (v1 <.> perp v2) < 0 diff --git a/src/Diagrams/Util.hs b/src/Diagrams/Util.hs --- a/src/Diagrams/Util.hs +++ b/src/Diagrams/Util.hs @@ -26,8 +26,8 @@ ) where -import Data.Monoid -import Data.Default +import Data.Default.Class +import Data.Monoid -- | Several functions exported by the diagrams library take a number -- of arguments giving the user control to \"tweak\" various aspects @@ -42,7 +42,9 @@ -- a synonym for 'def', which provides nice-looking syntax for -- simulating optional, named arguments in Haskell. For example, -- --- > polygon with {sides = 7, edgeSkip = 2} +-- @ +-- polygon with {sides = 7, edgeSkip = 2} +-- @ -- -- calls the 'polygon' function with a single argument (note that -- record update binds more tightly than function application!), @@ -93,7 +95,9 @@ -- in the case of an empty list, perform a /balanced/ fold over a -- list. For example, -- --- > foldB (+) z [a,b,c,d,e,f] == ((a+b) + (c+d)) + (e+f) +-- @ +-- foldB (+) z [a,b,c,d,e,f] == ((a+b) + (c+d)) + (e+f) +-- @ -- foldB :: (a -> a -> a) -> a -> [a] -> a foldB _ z [] = z