diagrams-lib 1.5.1 → 1.6
raw patch · 32 files changed
+4813/−4251 lines, 32 filesdep +base-compatdep −deepseqdep −faildep −profunctorsdep ~basedep ~containersdep ~diagrams-corePVP ok
version bump matches the API change (PVP)
Dependencies added: base-compat
Dependencies removed: deepseq, fail, profunctors, semigroups, tagged, text
Dependency ranges changed: base, containers, diagrams-core, diagrams-solve, lens
API changes (from Hackage documentation)
- Diagrams.Trail: instance (GHC.Classes.Ord n, GHC.Float.Floating n, Linear.Metric.Metric v) => GHC.Base.Monoid (Diagrams.Trail.SegTree v n)
- Diagrams.Trail: instance (GHC.Classes.Ord n, GHC.Float.Floating n, Linear.Metric.Metric v) => GHC.Base.Semigroup (Diagrams.Trail.SegTree v n)
+ Diagrams.CubicSpline.NonSingleton: [:||] :: forall a. a -> NonEmpty a -> NonSingleton a
+ Diagrams.CubicSpline.NonSingleton: data NonSingleton a
+ Diagrams.CubicSpline.NonSingleton: dupFirst :: NonSingleton a -> NonSingleton a
+ Diagrams.CubicSpline.NonSingleton: dupLast :: NonEmpty a -> NonSingleton a
+ Diagrams.CubicSpline.NonSingleton: infixr 5 :||
+ Diagrams.CubicSpline.NonSingleton: instance GHC.Base.Functor Diagrams.CubicSpline.NonSingleton.NonSingleton
+ Diagrams.CubicSpline.NonSingleton: tail :: NonSingleton a -> NonEmpty a
+ Diagrams.CubicSpline.NonSingleton: toNonEmpty :: NonSingleton a -> NonEmpty a
+ Diagrams.CubicSpline.NonSingleton: zipWith :: (a -> b -> c) -> NonSingleton a -> NonSingleton b -> NonSingleton c
+ Diagrams.Trail: instance (GHC.Float.Floating n, GHC.Classes.Ord n, Linear.Metric.Metric v) => GHC.Base.Monoid (Diagrams.Trail.SegTree v n)
+ Diagrams.Trail: instance (GHC.Float.Floating n, GHC.Classes.Ord n, Linear.Metric.Metric v) => GHC.Base.Semigroup (Diagrams.Trail.SegTree v n)
- Diagrams.CubicSpline: type BSpline (v :: Type -> Type) n = [Point v n]
+ Diagrams.CubicSpline: type BSpline (v :: Type -> Type) n = NonEmpty Point v n
- Diagrams.CubicSpline.Boehm: type BSpline (v :: Type -> Type) n = [Point v n]
+ Diagrams.CubicSpline.Boehm: type BSpline (v :: Type -> Type) n = NonEmpty Point v n
- Diagrams.CubicSpline.Internal: solveCubicSplineCoefficients :: Fractional a => Bool -> [a] -> [[a]]
+ Diagrams.CubicSpline.Internal: solveCubicSplineCoefficients :: Fractional a => Bool -> NonSingleton a -> [[a]]
- Diagrams.CubicSpline.Internal: solveCubicSplineDerivatives :: Fractional a => [a] -> [a]
+ Diagrams.CubicSpline.Internal: solveCubicSplineDerivatives :: Fractional a => NonSingleton a -> NonEmpty a
- Diagrams.CubicSpline.Internal: solveCubicSplineDerivativesClosed :: Fractional a => [a] -> [a]
+ Diagrams.CubicSpline.Internal: solveCubicSplineDerivativesClosed :: Fractional a => NonSingleton a -> NonEmpty a
- Diagrams.TwoD.Points: sortedConvexHull :: OrderedField n => [P2 n] -> ([P2 n], [P2 n])
+ Diagrams.TwoD.Points: sortedConvexHull :: OrderedField n => NonEmpty (P2 n) -> (NonEmpty (P2 n), NonEmpty (P2 n))
- Diagrams.TwoD.Segment.Bernstein: BernsteinPoly :: Int -> [n] -> BernsteinPoly n
+ Diagrams.TwoD.Segment.Bernstein: BernsteinPoly :: Int -> NonEmpty n -> BernsteinPoly n
- Diagrams.TwoD.Segment.Bernstein: [bernsteinCoeffs] :: BernsteinPoly n -> [n]
+ Diagrams.TwoD.Segment.Bernstein: [bernsteinCoeffs] :: BernsteinPoly n -> NonEmpty n
Files
- CHANGELOG.md +18/−0
- diagrams-lib.cabal +9/−16
- src/Diagrams/Attributes.hs +8/−9
- src/Diagrams/Backend/CmdLine.hs +191/−173
- src/Diagrams/Combinators.hs +161/−133
- src/Diagrams/CubicSpline.hs +31/−33
- src/Diagrams/CubicSpline/Boehm.hs +77/−70
- src/Diagrams/CubicSpline/Internal.hs +51/−43
- src/Diagrams/CubicSpline/NonSingleton.hs +47/−0
- src/Diagrams/Path.hs +77/−86
- src/Diagrams/Prelude.hs +72/−75
- src/Diagrams/Segment.hs +261/−225
- src/Diagrams/Size.hs +88/−78
- src/Diagrams/ThreeD/Attributes.hs +4/−5
- src/Diagrams/ThreeD/Camera.hs +0/−3
- src/Diagrams/ThreeD/Light.hs +0/−2
- src/Diagrams/ThreeD/Shapes.hs +0/−5
- src/Diagrams/Trail.hs +1525/−1382
- src/Diagrams/Transform/ScaleInv.hs +0/−1
- src/Diagrams/TwoD/Arrow.hs +373/−344
- src/Diagrams/TwoD/Arrowheads.hs +197/−177
- src/Diagrams/TwoD/Attributes.hs +159/−105
- src/Diagrams/TwoD/Image.hs +78/−72
- src/Diagrams/TwoD/Offset.hs +277/−244
- src/Diagrams/TwoD/Path.hs +242/−198
- src/Diagrams/TwoD/Points.hs +32/−36
- src/Diagrams/TwoD/Polygons.hs +251/−226
- src/Diagrams/TwoD/Segment.hs +216/−208
- src/Diagrams/TwoD/Segment/Bernstein.hs +85/−81
- src/Diagrams/TwoD/Shapes.hs +151/−129
- src/Diagrams/TwoD/Text.hs +131/−91
- src/Diagrams/Util.hs +1/−1
CHANGELOG.md view
@@ -1,3 +1,21 @@+## [v1.6](https://github.com/diagrams/diagrams-lib/tree/v1.6) (2026-08-06)++- Fix a ton of warnings+ - Remove redundant `Typable` derivations+ - Use safer function variants, `NonEmpty`, etc.+ - Redefine `Diagrams.CubicSpline.Boehm.BSpline` as `NonEmpty (Point v n)`+ - New module `Diagrams.CubicSpline.Nonsingleton` for lists with at+ least two elements, needed for safe operation of `CubicSpline`+ methods+- Dependency updates+ - Allow `base-4.22` and test on GHC 9.14+ - Remove support for GHC 8.4+ - Depend on `diagrams-solve-0.3`+ - Allow `containers-0.8`+ - Remove unused dependencies `semigroups`, `tagged`, `text`,+ `profunctors`, `fail`, `deepseq`+- Fix documentation for `splitTextureFills` (thanks to @kostmo)+ ## [v1.5.1](https://github.com/diagrams/diagrams-lib/tree/v1.5.1) (2025-12-02) - New `Semigroup` instance for located lines (i.e. `Located (Trail'
diagrams-lib.cabal view
@@ -1,5 +1,5 @@ Name: diagrams-lib-Version: 1.5.1+Version: 1.6 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@@ -21,7 +21,7 @@ Cabal-version: 1.18 Extra-source-files: diagrams/*.svg Extra-doc-files: CHANGELOG.md, README.markdown, diagrams/*.svg-Tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.2 || ==9.10.1 || ==9.12.1+Tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.2 || ==9.10.1 || ==9.12.1 || ==9.14.1 Source-repository head type: git location: http://github.com/diagrams/diagrams-lib.git@@ -42,6 +42,7 @@ Diagrams.CubicSpline, Diagrams.CubicSpline.Boehm, Diagrams.CubicSpline.Internal,+ Diagrams.CubicSpline.NonSingleton, Diagrams.Deform Diagrams.Direction, Diagrams.Envelope,@@ -101,21 +102,20 @@ Diagrams.TwoD.Vector, Diagrams.Util other-modules: Linear.Vector.Compat- Build-depends: base >= 4.9 && < 4.22,- containers >= 0.3 && < 0.8,+ Build-depends: base >= 4.9 && < 4.23,+ base-compat >= 0.9,+ containers >= 0.3 && < 0.9, array >= 0.3 && < 0.6,- semigroups >= 0.3.4 && < 0.21, monoid-extras >= 0.6 && < 0.8, dual-tree >= 0.2 && < 0.3, diagrams-core >= 1.4 && < 1.6,- diagrams-solve >= 0.1 && < 0.2,+ diagrams-solve >= 0.3 && < 0.4, active >= 0.2 && < 0.3, colour >= 2.3.2 && < 2.4, data-default >= 0.8 && < 0.9, fingertree >= 0.1 && < 0.2, intervals >= 0.7 && < 0.10, lens >= 5.1 && < 5.4,- tagged >= 0.7 && < 0.9, optparse-applicative >= 0.11 && < 0.20, filepath >= 1.4 && < 1.6, JuicyPixels >= 3.3.4 && < 3.4,@@ -126,14 +126,11 @@ process >= 1.1 && < 1.7, directory >= 1.2 && < 1.4, unordered-containers >= 0.2 && < 0.3,- text >= 0.7.1 && < 2.2, mtl >= 2.0 && < 2.3 || >= 2.3.1 && < 2.4, transformers >= 0.3.0 && < 0.7.0,- profunctors >= 5.0 && < 6.0, exceptions >= 0.6 && < 1.0, cereal >=0.4.1.1 && <0.6,- bytestring >=0.9 && <0.13,- fail >= 4.9.0.0 && <4.10+ bytestring >=0.9 && <0.13 Hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010@@ -162,12 +159,9 @@ tasty-hunit >= 0.9.2 && < 0.11, tasty-quickcheck >= 0.8 && < 0.12, QuickCheck >= 2.7,- deepseq >= 1.3 && < 1.6, diagrams-lib,- lens, distributive,- numeric-extras,- diagrams-solve+ numeric-extras default-language: Haskell2010 benchmark benchmarks@@ -178,5 +172,4 @@ build-depends: base < 5, criterion,- diagrams-core, diagrams-lib
src/Diagrams/Attributes.hs view
@@ -131,7 +131,7 @@ -- | Line widths specified on child nodes always override line widths -- specified at parent nodes. newtype LineWidth n = LineWidth (Last n)- deriving (Typeable, Semigroup)+ deriving (Semigroup) _LineWidth :: Iso' (LineWidth n) n _LineWidth = iso getLineWidth (LineWidth . Last)@@ -194,7 +194,7 @@ -- | Create lines that are dashing... er, dashed. data Dashing n = Dashing [n] n- deriving (Functor, Typeable, Eq)+ deriving (Functor, Eq) instance Semigroup (Dashing n) where _ <> b = b@@ -268,7 +268,6 @@ -- | An existential wrapper for instances of the 'Color' class. data SomeColor = forall c. Color c => SomeColor c- deriving Typeable instance Show SomeColor where showsPrec d (colorToSRGBA -> (r,g,b,a)) =@@ -330,7 +329,7 @@ -- words, for example, @opacity 0.8@ means \"decrease this diagram's -- opacity to 80% of its previous opacity\". newtype Opacity = Opacity (Product Double)- deriving (Typeable, Semigroup)+ deriving (Semigroup) instance AttributeClass Opacity _Opacity :: Iso' Opacity Double@@ -356,7 +355,7 @@ -- (completely opaque, the default) and 0 (completely transparent), -- and is multiplicative. newtype FillOpacity = FillOpacity (Product Double)- deriving (Typeable, Semigroup)+ deriving (Semigroup) instance AttributeClass FillOpacity _FillOpacity :: Iso' FillOpacity Double@@ -382,7 +381,7 @@ -- (completely opaque, the default) and 0 (completely transparent), -- and is multiplicative. newtype StrokeOpacity = StrokeOpacity (Product Double)- deriving (Typeable, Semigroup)+ deriving (Semigroup) instance AttributeClass StrokeOpacity _StrokeOpacity :: Iso' StrokeOpacity Double@@ -413,7 +412,7 @@ -- centered on endpoints. | LineCapSquare -- ^ Lines are capped with a squares -- centered on endpoints.- deriving (Eq, Ord, Show, Typeable)+ deriving (Eq, Ord, Show) instance Default LineCap where def = LineCapButt@@ -443,7 +442,7 @@ | LineJoinBevel -- ^ Use a \"bevel\" shape (whatever -- that is). Are these... -- carpentry terms?- deriving (Eq, Ord, Show, Typeable)+ deriving (Eq, Ord, Show) instance AttributeClass LineJoin @@ -470,7 +469,7 @@ -- | Miter limit attribute affecting the 'LineJoinMiter' joins. -- For some backends this value may have additional effects. newtype LineMiterLimit = LineMiterLimit (Last Double)- deriving (Typeable, Semigroup, Eq, Ord)+ deriving (Semigroup, Eq, Ord) instance AttributeClass LineMiterLimit _LineMiterLimit :: Iso' LineMiterLimit Double
src/Diagrams/Backend/CmdLine.hs view
@@ -1,14 +1,14 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstrainedClassMethods #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}------------------------------------------------------------------------------+ -- | -- Module : Diagrams.Backend.CmdLine -- Copyright : (c) 2013 Diagrams team (see LICENSE)@@ -24,105 +24,99 @@ -- -- For a tutorial on command-line diagram creation see -- <https://diagrams.github.io/doc/cmdline.html>.-----------------------------------------------------------------------------------module Diagrams.Backend.CmdLine- (-- -- * Options-- -- ** Standard options- DiagramOpts(..)- , diagramOpts- , width- , height- , output-- -- ** Multi-diagram options- , DiagramMultiOpts(..)- , diagramMultiOpts- , selection- , list-- -- ** Animation options- , DiagramAnimOpts(..)- , diagramAnimOpts- , fpu-- -- * Parsing- , Parseable(..)- , readHexColor-- -- * Command-line programs (@Mainable@)- -- ** Arguments, rendering, and entry point- , Mainable(..)+module Diagrams.Backend.CmdLine (+ -- * Options - -- ** General currying- , ToResult(..)+ -- ** Standard options+ DiagramOpts (..),+ diagramOpts,+ width,+ height,+ output, - -- ** helper functions for implementing @mainRender@- , defaultAnimMainRender- , defaultMultiMainRender- ) where+ -- ** Multi-diagram options+ DiagramMultiOpts (..),+ diagramMultiOpts,+ selection,+ list, -import Control.Lens (Lens', makeLenses, (&), (.~), (^.))-import Diagrams.Animation-import Diagrams.Attributes-import Diagrams.Core hiding (output)+ -- ** Animation options+ DiagramAnimOpts (..),+ diagramAnimOpts,+ fpu, -import Options.Applicative-import Options.Applicative.Types (readerAsk)+ -- * Parsing+ Parseable (..),+ readHexColor, -import Control.Monad (forM_)+ -- * Command-line programs (@Mainable@) --- MonadFail comes from Prelude in base-4.13 and up-#if !MIN_VERSION_base(4,13,0)-import Control.Monad.Fail (MonadFail)-#endif+ -- ** Arguments, rendering, and entry point+ Mainable (..), -import Data.Active hiding (interval)-import Data.Char (isDigit)-import Data.Colour-import Data.Colour.Names-import Data.Colour.SRGB-import Data.Data-import Data.Functor.Identity-import Data.Kind (Type)-import Data.Monoid-import Numeric+ -- ** General currying+ ToResult (..), -import System.Environment (getProgName)-import System.FilePath (addExtension, splitExtension)+ -- ** helper functions for implementing @mainRender@+ defaultAnimMainRender,+ defaultMultiMainRender,+) where -import Text.Printf+import Control.Lens (Lens', makeLenses, (&), (.~), (^.))+import Control.Monad (forM_)+import Control.Monad.Fail.Compat (MonadFail)+import Data.Active hiding (interval)+import Data.Char (isDigit)+import Data.Colour+import Data.Colour.Names+import Data.Colour.SRGB+import Data.Data+import Data.Functor.Identity+import Data.Kind (Type)+import Data.Monoid+import Diagrams.Animation+import Diagrams.Attributes+import Diagrams.Core hiding (output)+import Numeric+import Options.Applicative+import Options.Applicative.Types (readerAsk)+import System.Environment (getProgName)+import System.FilePath (addExtension, splitExtension)+import Text.Printf+import Prelude hiding (MonadFail) -- | Standard options most diagrams are likely to have. data DiagramOpts = DiagramOpts- { _width :: Maybe Int -- ^ Final output width of diagram.- , _height :: Maybe Int -- ^ Final output height of diagram.- , _output :: FilePath -- ^ Output file path, format is typically chosen by extension.+ { _width :: Maybe Int+ -- ^ Final output width of diagram.+ , _height :: Maybe Int+ -- ^ Final output height of diagram.+ , _output :: FilePath+ -- ^ Output file path, format is typically chosen by extension. }- deriving (Show, Data, Typeable)+ deriving (Show, Data) makeLenses ''DiagramOpts -- | Extra options for a program that can offer a choice -- between multiple diagrams. data DiagramMultiOpts = DiagramMultiOpts- { _selection :: Maybe String -- ^ Selected diagram to render.- , _list :: Bool -- ^ Flag to indicate that a list of available diagrams should- -- be printed to standard out.+ { _selection :: Maybe String+ -- ^ Selected diagram to render.+ , _list :: Bool+ -- ^ Flag to indicate that a list of available diagrams should+ -- be printed to standard out. }- deriving (Show, Data, Typeable)+ deriving (Show, Data) makeLenses ''DiagramMultiOpts -- | Extra options for animations. data DiagramAnimOpts = DiagramAnimOpts- { _fpu :: Double -- ^ Number of frames per unit time to generate for the animation.+ { _fpu :: Double+ -- ^ Number of frames per unit time to generate for the animation. }- deriving (Show, Data, Typeable)+ deriving (Show, Data) makeLenses ''DiagramAnimOpts @@ -131,53 +125,71 @@ -- Height is option @--height@ or @-h@ (note we change help to be @-?@ due to this). -- Output is option @--output@ or @-o@. diagramOpts :: Parser DiagramOpts-diagramOpts = DiagramOpts- <$> (optional . option auto)- ( long "width" <> short 'w'- <> metavar "WIDTH"- <> help "Desired WIDTH of the output image")- <*> (optional . option auto)- ( long "height" <> short 'h'- <> metavar "HEIGHT"- <> help "Desired HEIGHT of the output image")- <*> strOption- ( long "output" <> short 'o'- <> value ""- <> metavar "OUTPUT"- <> help "OUTPUT file")+diagramOpts =+ DiagramOpts+ <$> (optional . option auto)+ ( long "width"+ <> short 'w'+ <> metavar "WIDTH"+ <> help "Desired WIDTH of the output image"+ )+ <*> (optional . option auto)+ ( long "height"+ <> short 'h'+ <> metavar "HEIGHT"+ <> help "Desired HEIGHT of the output image"+ )+ <*> strOption+ ( long "output"+ <> short 'o'+ <> value ""+ <> metavar "OUTPUT"+ <> help "OUTPUT file"+ ) -- | Command line parser for 'DiagramMultiOpts'. -- Selection is option @--selection@ or @-S@. -- List is @--list@ or @-L@. diagramMultiOpts :: Parser DiagramMultiOpts-diagramMultiOpts = DiagramMultiOpts- <$> (optional . strOption)- ( long "selection" <> short 'S'- <> metavar "NAME"- <> help "NAME of the diagram to render")- <*> switch- ( long "list" <> short 'L'- <> help "List all available diagrams")+diagramMultiOpts =+ DiagramMultiOpts+ <$> (optional . strOption)+ ( long "selection"+ <> short 'S'+ <> metavar "NAME"+ <> help "NAME of the diagram to render"+ )+ <*> switch+ ( long "list"+ <> short 'L'+ <> help "List all available diagrams"+ ) -- | Command line parser for 'DiagramAnimOpts' -- Frames per unit is @--fpu@ or @-f@. diagramAnimOpts :: Parser DiagramAnimOpts-diagramAnimOpts = DiagramAnimOpts- <$> option auto- ( long "fpu" <> short 'f'- <> value 30.0- <> help "Frames per unit time (for animations)")+diagramAnimOpts =+ DiagramAnimOpts+ <$> option+ auto+ ( long "fpu"+ <> short 'f'+ <> value 30.0+ <> help "Frames per unit time (for animations)"+ ) -- | A hidden \"helper\" option which always fails. -- Taken from Options.Applicative.Extra but without the -- short option 'h'. We want the 'h' for Height. helper' :: Parser (a -> a)-helper' = abortOption param $ mconcat- [ long "help"- , short '?'- , help "Show this help text"- ]- where+helper' =+ abortOption param $+ mconcat+ [ long "help"+ , short '?'+ , help "Show this help text"+ ]+ where #if MIN_VERSION_optparse_applicative(0,16,0) param = ShowHelpText Nothing #else@@ -190,10 +202,13 @@ defaultOpts :: Parser a -> IO a defaultOpts optsParser = do prog <- getProgName- let p = info (helper' <*> optsParser)- ( fullDesc- <> progDesc "Command-line diagram generation."- <> header prog)+ let p =+ info+ (helper' <*> optsParser)+ ( fullDesc+ <> progDesc "Command-line diagram generation."+ <> header prog+ ) execParser p -- | Parseable instances give a command line parser for a type. If a custom@@ -240,20 +255,20 @@ -- or a hexadecimal color. instance Parseable (Colour Double) where parser = argument (rc <|> rh) mempty- where- rh, rc :: ReadM (Colour Double)- rh = f . colorToSRGBA <$> (readerAsk >>= readHexColor)- rc = readerAsk >>= readColourName- f (r,g,b,_) = sRGB r g b -- TODO: this seems unfortunate. Should the alpha- -- value be applied to the r g b values?+ where+ rh, rc :: ReadM (Colour Double)+ rh = f . colorToSRGBA <$> (readerAsk >>= readHexColor)+ rc = readerAsk >>= readColourName+ f (r, g, b, _) = sRGB r g b -- TODO: this seems unfortunate. Should the alpha+ -- value be applied to the r g b values? -- | Parse @'AlphaColour' Double@ as either a named color from "Data.Colour.Names" -- or a hexadecimal color. instance Parseable (AlphaColour Double) where parser = argument (rc <|> rh) mempty- where- rh = readerAsk >>= readHexColor- rc = opaque <$> (readerAsk >>= readColourName)+ where+ rh = readerAsk >>= readHexColor+ rc = opaque <$> (readerAsk >>= readColourName) -- Addapted from the Clay.Color module of the clay package @@ -265,25 +280,25 @@ -- order being red, green, blue, alpha. readHexColor :: (Applicative m, MonadFail m) => String -> m (AlphaColour Double) readHexColor cs = case cs of- ('0':'x':hs) -> handle hs- ('#':hs) -> handle hs- hs -> handle hs- where- handle hs | length hs <= 8 && all isHexDigit hs- = case hs of- [a,b,c,d,e,f,g,h] -> withOpacity <$> (sRGB <$> hex a b <*> hex c d <*> hex e f) <*> hex g h- [a,b,c,d,e,f ] -> opaque <$> (sRGB <$> hex a b <*> hex c d <*> hex e f)- [a,b,c,d ] -> withOpacity <$> (sRGB <$> hex a a <*> hex b b <*> hex c c) <*> hex d d- [a,b,c ] -> opaque <$> (sRGB <$> hex a a <*> hex b b <*> hex c c)- _ -> fail $ "could not parse as a colour" ++ cs- handle _ = fail $ "could not parse as a colour: " ++ cs-- isHexDigit c = isDigit c || c `elem` "abcdef"+ ('0' : 'x' : hs) -> handle hs+ ('#' : hs) -> handle hs+ hs -> handle hs+ where+ handle hs | length hs <= 8 && all isHexDigit hs =+ case hs of+ [a, b, c, d, e, f, g, h] -> withOpacity <$> (sRGB <$> hex a b <*> hex c d <*> hex e f) <*> hex g h+ [a, b, c, d, e, f] -> opaque <$> (sRGB <$> hex a b <*> hex c d <*> hex e f)+ [a, b, c, d] -> withOpacity <$> (sRGB <$> hex a a <*> hex b b <*> hex c c) <*> hex d d+ [a, b, c] -> opaque <$> (sRGB <$> hex a a <*> hex b b <*> hex c c)+ _ -> fail $ "could not parse as a colour" ++ cs+ handle _ = fail $ "could not parse as a colour: " ++ cs - hex a b = (/ 255) <$> case readHex [a,b] of- [(h,"")] -> return h- _ -> fail $ "could not parse as a hex value" ++ [a,b]+ isHexDigit c = isDigit c || c `elem` "abcdef" + hex a b =+ (/ 255) <$> case readHex [a, b] of+ [(h, "")] -> return h+ _ -> fail $ "could not parse as a hex value" ++ [a, b] -- | This instance is needed to signal the end of a chain of -- nested tuples, it always just results in the unit value@@ -292,7 +307,7 @@ parser = pure () -- | Allow 'Parseable' things to be combined.-instance (Parseable a, Parseable b) => Parseable (a,b) where+instance (Parseable a, Parseable b) => Parseable (a, b) where parser = (,) <$> parser <*> parser -- | Triples of Parsebales should also be Parseable.@@ -330,8 +345,8 @@ -- | A list of named diagrams can give the multi-diagram interface. instance ToResult [(String, QDiagram b v n Any)] where- type Args [(String,QDiagram b v n Any)] = ()- type ResultOf [(String,QDiagram b v n Any)] = [(String,QDiagram b v n Any)]+ type Args [(String, QDiagram b v n Any)] = ()+ type ResultOf [(String, QDiagram b v n Any)] = [(String, QDiagram b v n Any)] toResult ds _ = ds @@ -362,8 +377,7 @@ type Args (a -> d) = (a, Args d) type ResultOf (a -> d) = ResultOf d - toResult f (a,args) = toResult (f a) args-+ toResult f (a, args) = toResult (f a) args -- | This class represents the various ways we want to support diagram creation -- from the command line. It has the right instances to select between creating@@ -420,11 +434,14 @@ -- | This instance allows functions resulting in something that is 'Mainable' to -- be 'Mainable'. It takes a parse of collected arguments and applies them to -- the given function producing the 'Mainable' result.-instance (ToResult d, Mainable (ResultOf d))- => Mainable (a -> d) where+instance+ (ToResult d, Mainable (ResultOf d)) =>+ Mainable (a -> d)+ where type MainOpts (a -> d) = (MainOpts (ResultOf (a -> d)), Args (a -> d)) - mainRender (opts, a) f = mainRender opts (toResult f a)+ mainRender (opts, a) f = mainRender opts (toResult f a)+ -- TODO: why can't we get away with: instance (Parseable (Args (a -> d)), Mainable (ResultOf d)) => ... -- Doesn't `Args (a -> d)` imply `ToResult (a -> d)` which implies `ToResult d` ? @@ -452,14 +469,14 @@ -- We do not provide this instance in general so that backends can choose to -- opt-in to this form or provide a different instance that makes more sense. defaultMultiMainRender :: Mainable d => (MainOpts d, DiagramMultiOpts) -> [(String, d)] -> IO ()-defaultMultiMainRender (opts,multi) ds =- if multi^.list+defaultMultiMainRender (opts, multi) ds =+ if multi ^. list then showDiaList (map fst ds)- else case multi^.selection of- Nothing -> putStrLn "No diagram selected." >> showDiaList (map fst ds)- Just sel -> case lookup sel ds of- Nothing -> putStrLn $ "Unknown diagram: " ++ sel- Just d -> mainRender opts d+ else case multi ^. selection of+ Nothing -> putStrLn "No diagram selected." >> showDiaList (map fst ds)+ Just sel -> case lookup sel ds of+ Nothing -> putStrLn $ "Unknown diagram: " ++ sel+ Just d -> mainRender opts d -- | Display the list of diagrams available for rendering. showDiaList :: [String] -> IO ()@@ -496,23 +513,24 @@ -- -- We do not provide this instance in general so that backends can choose to -- opt-in to this form or provide a different instance that makes more sense.- defaultAnimMainRender ::- (opts -> QDiagram b v n Any -> IO ())- -> Lens' opts FilePath -- ^ A lens into the output path.- -> (opts, DiagramAnimOpts)- -> Animation b v n- -> IO ()-defaultAnimMainRender renderF out (opts,animOpts) anim = do- let frames = simulate (toRational $ animOpts^.fpu) anim+ (opts -> QDiagram b v n Any -> IO ()) ->+ -- | A lens into the output path.+ Lens' opts FilePath ->+ (opts, DiagramAnimOpts) ->+ Animation b v n ->+ IO ()+defaultAnimMainRender renderF out (opts, animOpts) anim = do+ let frames = simulate (toRational $ animOpts ^. fpu) anim nDigits = length . show . length $ frames- forM_ (zip [1..] frames) $ \(i,d) -> renderF (indexize out nDigits i opts) d+ forM_ (zip [1 ..] frames) $ \(i, d) -> renderF (indexize out nDigits i opts) d -- | @indexize d n@ adds the integer index @n@ to the end of the -- output file name, padding with zeros if necessary so that it uses -- at least @d@ digits. indexize :: Lens' s FilePath -> Int -> Integer -> s -> s indexize out nDigits i opts = opts & out .~ output'- where fmt = "%0" ++ show nDigits ++ "d"- output' = addExtension (base ++ printf fmt i) ext- (base, ext) = splitExtension (opts^.out)+ where+ fmt = "%0" ++ show nDigits ++ "d"+ output' = addExtension (base ++ printf fmt i) ext+ (base, ext) = splitExtension (opts ^. out)
src/Diagrams/Combinators.hs view
@@ -1,11 +1,15 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module : Diagrams.Combinators -- Copyright : (c) 2011 diagrams-lib team (see LICENSE)@@ -13,52 +17,55 @@ -- Maintainer : diagrams-discuss@googlegroups.com -- -- Higher-level tools for combining diagrams.-----------------------------------------------------------------------------------module Diagrams.Combinators- ( -- * Unary operations-- withEnvelope, withTrace- , phantom, strut- , pad, frame- , extrudeEnvelope, intrudeEnvelope-- -- * Binary operations- , atop- , beneath- , beside- , atDirection+module Diagrams.Combinators (+ -- * Unary operations+ withEnvelope,+ withTrace,+ phantom,+ strut,+ pad,+ frame,+ extrudeEnvelope,+ intrudeEnvelope, - -- * n-ary operations- , appends- , position, atPoints- , cat, cat'- , CatOpts(_catMethod, _sep), catMethod, sep- , CatMethod(..)- , composeAligned+ -- * Binary operations+ atop,+ beneath,+ beside,+ atDirection, - ) where+ -- * n-ary operations+ appends,+ position,+ atPoints,+ cat,+ cat',+ CatOpts (_catMethod, _sep),+ catMethod,+ sep,+ CatMethod (..),+ composeAligned,+) where -import Control.Lens hiding (beside, ( # ))-import Data.Default-import Data.Maybe (fromJust)-import Data.Monoid.Deletable (toDeletable)-import Data.Monoid.MList (inj)-import Data.Proxy-import Data.Semigroup-import qualified Data.Tree.DUAL as D+import Control.Lens hiding (beside, (#))+import Data.Default+import Data.Maybe (fromJust, listToMaybe)+import Data.Monoid.Deletable (toDeletable)+import Data.Monoid.MList (inj)+import Data.Proxy+import Data.Semigroup+import qualified Data.Tree.DUAL as D -import Diagrams.Core-import Diagrams.Core.Types (QDiagram (QD))-import Diagrams.Direction-import Diagrams.Names (named)-import Diagrams.Segment (straight)-import Diagrams.Util+import Diagrams.Core+import Diagrams.Core.Types (QDiagram (QD))+import Diagrams.Direction+import Diagrams.Names (named)+import Diagrams.Segment (straight)+import Diagrams.Util -import Linear.Affine-import Linear.Metric-import Linear.Vector+import Linear.Affine+import Linear.Metric+import Linear.Vector ------------------------------------------------------------ -- Working with envelopes@@ -77,14 +84,16 @@ -- > ) -- > c = circle 0.8 -- > withEnvelopeEx = sqNewEnv # centerXY # pad 1.5-withEnvelope :: (InSpace v n a, Monoid' m, Enveloped a)- => a -> QDiagram b v n m -> QDiagram b v n m+withEnvelope ::+ (InSpace v n a, Monoid' m, Enveloped a) =>+ a -> QDiagram b v n m -> QDiagram b v n m withEnvelope = setEnvelope . getEnvelope -- | Use the trace from some object as the trace for a diagram, in -- place of the diagram's default trace.-withTrace :: (InSpace v n a, Metric v, OrderedField n, Monoid' m, Traced a)- => a -> QDiagram b v n m -> QDiagram b v n m+withTrace ::+ (InSpace v n a, Metric v, OrderedField n, Monoid' m, Traced a) =>+ a -> QDiagram b v n m -> QDiagram b v n m withTrace = setTrace . getTrace -- | @phantom x@ produces a \"phantom\" diagram, which has the same@@ -98,16 +107,18 @@ -- origin, so if the origin is not centered the padding may appear -- \"uneven\". If this is not desired, the origin can be centered -- (using, e.g., 'centerXY' for 2D diagrams) before applying @pad@.-pad :: (Metric v, OrderedField n, Monoid' m)- => n -> QDiagram b v n m -> QDiagram b v n m+pad ::+ (Metric v, OrderedField n, Monoid' m) =>+ n -> QDiagram b v n m -> QDiagram b v n m pad s d = withEnvelope (d # scale s) d -- | @frame s@ increases the envelope of a diagram by and absolute amount @s@, -- s is in the local units of the diagram. This function is similar to @pad@, -- only it takes an absolute quantity and pre-centering should not be -- necessary.-frame :: (Metric v, OrderedField n, Monoid' m)- => n -> QDiagram b v n m -> QDiagram b v n m+frame ::+ (Metric v, OrderedField n, Monoid' m) =>+ n -> QDiagram b v n m -> QDiagram b v n m frame s = over envelope (onEnvelope $ \f x -> f x + s) -- | @strut v@ is a diagram which produces no output, but with respect@@ -121,19 +132,22 @@ -- <<diagrams/src_Diagrams_Combinators_strutEx.svg#diagram=strutEx&width=300>> -- -- > strutEx = (circle 1 ||| strut unitX ||| circle 1) # centerXY # pad 1.1-strut :: (Metric v, OrderedField n)- => v n -> QDiagram b v n m+strut ::+ (Metric v, OrderedField n) =>+ v n -> QDiagram b v n m strut v = QD $ D.leafU (inj . toDeletable $ env)- 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- -- a special 'strut' combinator (before the introduction of traces- -- it was mostly just for convenience).- --- -- also note that we can't remove the call to getEnvelope, since- -- translating a segment has no effect.+ 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+-- a special 'strut' combinator (before the introduction of traces+-- it was mostly just for convenience).+--+-- also note that we can't remove the call to getEnvelope, since+-- translating a segment has no effect.+ -- | @extrudeEnvelope v d@ asymmetrically \"extrudes\" the envelope of -- a diagram in the given direction. All parts of the envelope -- within 90 degrees of this direction are modified, offset outwards@@ -142,9 +156,9 @@ -- This works by offsetting the envelope distance proportionally to -- the cosine of the difference in angle, and leaving it unchanged -- when this factor is negative.-extrudeEnvelope- :: (Metric v, OrderedField n, Monoid' m)- => v n -> QDiagram b v n m -> QDiagram b v n m+extrudeEnvelope ::+ (Metric v, OrderedField n, Monoid' m) =>+ v n -> QDiagram b v n m -> QDiagram b v n m extrudeEnvelope = deformEnvelope 1 -- | @intrudeEnvelope v d@ asymmetrically \"intrudes\" the envelope of@@ -154,23 +168,23 @@ -- -- Note that this could create strange inverted envelopes, where -- @ diameter v d < 0 @.-intrudeEnvelope- :: (Metric v, OrderedField n, Monoid' m)- => v n -> QDiagram b v n m -> QDiagram b v n m+intrudeEnvelope ::+ (Metric v, OrderedField n, Monoid' m) =>+ v n -> QDiagram b v n m -> QDiagram b v n m intrudeEnvelope = deformEnvelope (-1) -- Utility for extrudeEnvelope / intrudeEnvelope-deformEnvelope- :: (Metric v, OrderedField n, Monoid' m)- => n -> v n -> QDiagram b v n m -> QDiagram b v n m+deformEnvelope ::+ (Metric v, OrderedField n, Monoid' m) =>+ n -> v n -> QDiagram b v n m -> QDiagram b v n m deformEnvelope s v = over (envelope . _Wrapping Envelope) deformE- where- deformE = fmap deformE'- deformE' env v'- | dp > 0 = Max $ getMax (env v') + (dp * s) / quadrance v'- | otherwise = env v'- where- dp = v' `dot` v+ where+ deformE = fmap deformE'+ deformE' env v'+ | dp > 0 = Max $ getMax (env v') + (dp * s) / quadrance v'+ | otherwise = env v'+ where+ dp = v' `dot` v ------------------------------------------------------------ -- Combining two objects@@ -179,8 +193,9 @@ -- | @beneath@ is just a convenient synonym for @'flip' 'atop'@; that is, -- @d1 \`beneath\` d2@ is the diagram with @d2@ superimposed on top of -- @d1@.-beneath :: (Metric v, OrderedField n, Monoid' m)- => QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m+beneath ::+ (Metric v, OrderedField n, Monoid' m) =>+ QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m beneath = flip atop infixl 6 `beneath`@@ -228,8 +243,9 @@ -- from the first. The local origin of the resulting combined -- diagram is the same as the local origin of the first. See the -- documentation of 'beside' for more information.-atDirection :: (InSpace v n a, Metric v, Floating n, Juxtaposable a, Semigroup a)- => Direction v n -> a -> a -> a+atDirection ::+ (InSpace v n a, Metric v, Floating n, Juxtaposable a, Semigroup a) =>+ Direction v n -> a -> a -> a atDirection = beside . fromDirection ------------------------------------------------------------@@ -246,8 +262,8 @@ -- > appendsEx = appends c (zip (iterateN 6 (rotateBy (1/6)) unitX) (repeat c)) -- > # centerXY # pad 1.1 -- > where c = circle 1-appends :: (Juxtaposable a, Monoid' a) => a -> [(Vn a,a)] -> a-appends d1 apps = d1 <> mconcat (map (\(v,d) -> juxtapose v d1 d) apps)+appends :: (Juxtaposable a, Monoid' a) => a -> [(Vn a, a)] -> a+appends d1 apps = d1 <> mconcat (map (\(v, d) -> juxtapose v d1 d) apps) -- | Position things absolutely: combine a list of objects -- (e.g. diagrams or paths) by assigning them absolute positions in@@ -268,26 +284,30 @@ atPoints ps as = position $ zip ps as -- | Methods for concatenating diagrams.-data CatMethod = Cat -- ^ Normal catenation: simply put diagrams- -- next to one another (possibly with a- -- certain distance in between each). The- -- distance between successive diagram- -- /envelopes/ will be consistent; the- -- distance between /origins/ may vary if- -- the diagrams are of different sizes.- | Distrib -- ^ Distribution: place the local origins of- -- diagrams at regular intervals. With- -- this method, the distance between- -- successive /origins/ will be consistent- -- but the distance between envelopes may- -- not be. Indeed, depending on the amount- -- of separation, diagrams may overlap.+data CatMethod+ = -- | Normal catenation: simply put diagrams+ -- next to one another (possibly with a+ -- certain distance in between each). The+ -- distance between successive diagram+ -- /envelopes/ will be consistent; the+ -- distance between /origins/ may vary if+ -- the diagrams are of different sizes.+ Cat+ | -- | Distribution: place the local origins of+ -- diagrams at regular intervals. With+ -- this method, the distance between+ -- successive /origins/ will be consistent+ -- but the distance between envelopes may+ -- not be. Indeed, depending on the amount+ -- of separation, diagrams may overlap.+ Distrib -- | Options for 'cat''.-data CatOpts n = CatOpts { _catMethod :: CatMethod- , _sep :: n- , catOptsvProxy :: Proxy n- }+data CatOpts n = CatOpts+ { _catMethod :: CatMethod+ , _sep :: n+ , catOptsvProxy :: Proxy n+ } -- The reason the proxy field is necessary is that without it, -- altering the sep field could theoretically change the type of a@@ -313,10 +333,12 @@ sep :: Lens' (CatOpts n) n instance Num n => Default (CatOpts n) where- def = CatOpts { _catMethod = Cat- , _sep = 0- , catOptsvProxy = Proxy- }+ def =+ CatOpts+ { _catMethod = Cat+ , _sep = 0+ , catOptsvProxy = Proxy+ } -- | @cat v@ positions a list of objects so that their local origins -- lie along a line in the direction of @v@. Successive objects@@ -326,8 +348,9 @@ -- -- See also 'cat'', which takes an extra options record allowing -- certain aspects of the operation to be tweaked.-cat :: (InSpace v n a, Metric v, Floating n, Juxtaposable a, Monoid' a, HasOrigin a)- => v n -> [a] -> a+cat ::+ (InSpace v n a, Metric v, Floating n, Juxtaposable a, Monoid' a, HasOrigin a) =>+ v n -> [a] -> a cat v = cat' v def -- | Like 'cat', but taking an extra 'CatOpts' arguments allowing the@@ -347,13 +370,14 @@ -- Note that @cat' v (with & catMethod .~ Distrib) === mconcat@ -- (distributing with a separation of 0 is the same as -- superimposing).-cat' :: (InSpace v n a, Metric v, Floating n, Juxtaposable a, Monoid' a, HasOrigin a)- => v n -> CatOpts n -> [a] -> a-cat' v (CatOpts { _catMethod = Cat, _sep = s }) = foldB comb mempty- where comb d1 d2 = d1 <> (juxtapose v d1 d2 # moveOriginBy vs)- vs = s *^ signorm (negated v)--cat' v (CatOpts { _catMethod = Distrib, _sep = s }) =+cat' ::+ (InSpace v n a, Metric v, Floating n, Juxtaposable a, Monoid' a, HasOrigin a) =>+ v n -> CatOpts n -> [a] -> a+cat' v (CatOpts {_catMethod = Cat, _sep = s}) = foldB comb mempty+ where+ comb d1 d2 = d1 <> (juxtapose v d1 d2 # moveOriginBy vs)+ vs = s *^ signorm (negated v)+cat' v (CatOpts {_catMethod = Distrib, _sep = s}) = position . zip (iterate (.+^ (s *^ signorm v)) origin) -- | Compose a list of diagrams using the given composition function,@@ -381,19 +405,23 @@ -- > alignedEx2 = (mconcat # composeAligned alignTL) [circle 1, square 1, triangle 1, pentagon 1] -- > # showOrigin -- > # frame 0.1-composeAligned- :: (Monoid' m, Floating n, Ord n, Metric v)- => (QDiagram b v n m -> QDiagram b v n m) -- ^ Alignment function- -> ([QDiagram b v n m] -> QDiagram b v n m) -- ^ Composition function- -> ([QDiagram b v n m] -> QDiagram b v n m)+composeAligned ::+ (Monoid' m, Floating n, Ord n, Metric v) =>+ -- | Alignment function+ (QDiagram b v n m -> QDiagram b v n m) ->+ -- | Composition function+ ([QDiagram b v n m] -> QDiagram b v n m) ->+ ([QDiagram b v n m] -> QDiagram b v n m) composeAligned _ combine [] = combine []-composeAligned algn comb (d:ds) = (comb $ map algn (d:ds)) # moveOriginTo l- where- mss = ( (() .>> d) -- qualify first to avoid stomping on an existing () name- # named () -- Mark the origin- # algn -- Apply the alignment function- )- -- then find out what happened to the origin- ^. subMap . _Wrapped . Control.Lens.at (toName ())- l = location . head . fromJust $ mss- -- the fromJust is Justified since we put the () name in+composeAligned algn comb (d : ds) = comb (map algn (d : ds)) # moveOriginTo l+ where+ mss =+ ( (() .>> d) -- qualify first to avoid stomping on an existing () name+ # named () -- Mark the origin+ # algn -- Apply the alignment function+ )+ -- then find out what happened to the origin+ ^. subMap . _Wrapped . Control.Lens.at (toName ())+ l = maybe origin location . listToMaybe . fromJust $ mss++-- the fromJust is Justified since we put the () name in
src/Diagrams/CubicSpline.hs view
@@ -1,11 +1,9 @@-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} ------------------------------------------------------------------------------ -- | -- Module : Diagrams.CubicSpline -- Copyright : (c) 2011 diagrams-lib team (see LICENSE)@@ -27,28 +25,27 @@ -- through any of the other control points. It depends on the control -- points in a "local" way, that is, changing one control point will -- only affect a local portion of the curve near that control point.----------------------------------------------------------------------------------module Diagrams.CubicSpline- (- -- * Constructing paths from cubic splines- cubicSpline- , BSpline- , bspline- ) where+module Diagrams.CubicSpline (+ -- * Constructing paths from cubic splines+ cubicSpline,+ BSpline,+ bspline,+) where -import Control.Lens (view)+import Control.Lens (view)+import Data.List.NonEmpty (NonEmpty (..))+import Diagrams.CubicSpline.NonSingleton (NonSingleton (..)) -import Diagrams.Core-import Diagrams.CubicSpline.Boehm-import Diagrams.CubicSpline.Internal-import Diagrams.Located (Located, at, mapLoc)-import Diagrams.Segment-import Diagrams.Trail-import Diagrams.TrailLike (TrailLike (..))+import Diagrams.Core+import Diagrams.CubicSpline.Boehm+import Diagrams.CubicSpline.Internal+import Diagrams.Located (Located, at, mapLoc)+import Diagrams.Segment+import Diagrams.Trail+import Diagrams.TrailLike (TrailLike (..)) -import Linear.Affine-import Linear.Metric+import Linear.Affine+import Linear.Metric -- | Construct a spline path-like thing of cubic segments from a list of -- vertices, with the first vertex as the starting point. The first@@ -65,15 +62,16 @@ -- -- For more information, see <http://mathworld.wolfram.com/CubicSpline.html>. cubicSpline :: (V t ~ v, N t ~ n, TrailLike t, Fractional (v n)) => Bool -> [Point v n] -> t-cubicSpline closed [] = trailLike . closeIf closed $ emptyLine `at` origin+cubicSpline closed [] = trailLike . closeIf closed $ emptyLine `at` origin cubicSpline closed [p] = trailLike . closeIf closed $ emptyLine `at` p-cubicSpline closed ps = flattenBeziers . map f . solveCubicSplineCoefficients closed . map (view lensP) $ 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:_):_)- = trailLike . closeIf closed $ lineFromSegments (map bez bs) `at` P b- bez [a,b,c,d] = bezier3 (b - a) (c - a) (d - a)+cubicSpline closed (p1 : p2 : ps) = flattenBeziers . map f . solveCubicSplineCoefficients closed . fmap (view lensP) $ (p1 :|| (p2 :| 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 : _) : _) =+ trailLike . closeIf closed $ lineFromSegments (map bez bs) `at` P b+ bez [a, b, c, d] = bezier3 (b - a) (c - a) (d - a) -closeIf :: (Metric v, OrderedField n)- => Bool -> Located (Trail' Line v n) -> Located (Trail v n)+closeIf ::+ (Metric v, OrderedField n) =>+ Bool -> Located (Trail' Line v n) -> Located (Trail v n) closeIf c = mapLoc (if c then wrapLoop . glueLine else wrapLine)
src/Diagrams/CubicSpline/Boehm.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} ------------------------------------------------------------------------------ -- | -- Module : Diagrams.CubicSpline.Boehm -- Copyright : (c) 2015 diagrams-lib team (see LICENSE)@@ -19,41 +18,50 @@ -- -- * Lyle Ramshaw, /Blossoming: A Connect-the-Dots Approach to Splines/, -- <http://www.hpl.hp.com/techreports/Compaq-DEC/SRC-RR-19.pdf>----------------------------------------------------------------------------------module Diagrams.CubicSpline.Boehm- ( BSpline- , bsplineToBeziers- , bspline- ) where+module Diagrams.CubicSpline.Boehm (+ BSpline,+ bsplineToBeziers,+ bspline,+) where -import Data.List (sort, tails)-import Diagrams.Core (N, Point, V, origin)-import Diagrams.Located (at, loc, unLoc)-import Diagrams.Segment (FixedSegment (..), fromFixedSeg)-import Diagrams.TrailLike (TrailLike, fromLocSegments)-import Diagrams.Util (iterateN)-import Linear.Vector (Additive)-import Linear.Vector.Compat (lerp)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Diagrams.Core (N, Point, V, origin)+import Diagrams.Located (at, loc, unLoc)+import Diagrams.Segment (FixedSegment (..), fromFixedSeg)+import Diagrams.TrailLike (TrailLike, fromLocSegments)+import Diagrams.Util (iterateN)+import Linear.Vector (Additive)+import Linear.Vector.Compat (lerp) -type BSpline v n = [Point v n]+type BSpline v n = NonEmpty (Point v n) -- | @affineCombo a b t x y@ computes an affine combination of x and y -- which lies at parameter t, if x has parameter a and y has parameter b. -- The usual @lerp@ arises by giving x parameter 0 and y parameter 1. affineCombo :: (Additive f, Fractional a) => a -> a -> a -> f a -> f a -> f a-affineCombo a b t = lerp ((t-a)/(b-a))+affineCombo a b t = lerp ((t - a) / (b - a)) +takeMaybe :: Int -> [a] -> Maybe [a]+takeMaybe 0 _ = Just []+takeMaybe _ [] = Nothing+takeMaybe k (a : as) = (a :) <$> takeMaybe (k - 1) as+ -- | @windows k xs@ yields all the length-@k@ windows from @xs@, e.g. -- @windows 3 [a,b,c,d,e] == [[a,b,c], [b,c,d], [c,d,e]]@.-windows :: Int -> [a] -> [[a]]-windows k = takeWhile ((==k) . length) . map (take k) . tails+windows :: Int -> [a] -> [NonEmpty a]+windows 0 _ = []+windows _ [] = []+windows k (a : as) = case takeMaybe (k - 1) as of+ Just as' -> (a :| as') : windows k as+ Nothing -> [] -- | @extend k xs@ extends @xs@ on both ends by prepending @k@ copies -- of its head and appending @k@ copies of its last element. For example, -- @extend 2 [1..5] == [1,1,1,2,3,4,5,5,5]@. extend :: Int -> [a] -> [a]-extend k xs = replicate k (head xs) ++ xs ++ replicate k (last xs)+extend _ [] = []+extend k (x : xs) = replicate k x ++ (x : xs) ++ replicate k (NE.last (x :| xs)) -- | A "polar point" is a point along with three knot values. -- We consider the "blossom" of a cubic spline, a 3-ary symmetric@@ -63,24 +71,24 @@ -- points may be combined to yield other points of interest. -- -- Invariant: knot values are in nondecreasing order.-data PolarPt v n = PP { unPP :: Point v n, _knots :: [n] }+data PolarPt v n = PP {unPP :: Point v n, _knots :: NonEmpty n} -mkPolarPt :: Ord n => Point v n -> [n] -> PolarPt v n-mkPolarPt pt kts = PP pt (sort kts)+mkPolarPt :: Ord n => Point v n -> NonEmpty n -> PolarPt v n+mkPolarPt pt kts = PP pt (NE.sort kts) -- | Precondition: the knots of the two polar points overlap, like abc -- and bcd. The @Int@ should be 0 or 1, indicating which knot to -- replicate (0 means to replicate b, yielding bbc, 1 means to -- replicate c, yielding bcc).-combine- :: (Additive v, Fractional n, Ord n)- => Int -> PolarPt v n -> PolarPt v n -> PolarPt v n-combine k (PP pt1 kts1) (PP pt2 kts2)- = mkPolarPt- (affineCombo (head kts1) (last kts2) newKt pt1 pt2)- (newKt : drop 1 kts1)- where- newKt = kts2 !! k+combine ::+ (Additive v, Fractional n, Ord n) =>+ Int -> PolarPt v n -> PolarPt v n -> PolarPt v n+combine k (PP pt1 kts1) (PP pt2 kts2) =+ mkPolarPt+ (affineCombo (NE.head kts1) (NE.last kts2) newKt pt1 pt2)+ (newKt :| NE.drop 1 kts1)+ where+ newKt = NE.toList kts2 !! k -- | Convert a uniform cubic B-spline to a sequence of cubic beziers. -- (/Uniform/ refers to the fact that the knots are assumed to be@@ -88,43 +96,43 @@ -- replicated so the cubic spline begins and ends at the first and -- last control points, tangent to the line from the end control -- point to the next.-bsplineToBeziers- :: (Additive v, Fractional n, Num n, Ord n)- => BSpline v n- -> [FixedSegment v n]+bsplineToBeziers ::+ (Additive v, Fractional n, Num n, Ord n) =>+ BSpline v n ->+ [FixedSegment v n] bsplineToBeziers controls = beziers- where- n = length controls- numKnots = n + 2- knots = iterateN numKnots (+1/(fromIntegral numKnots - 1)) 0+ where+ n = NE.length controls+ numKnots = n + 2+ knots = iterateN numKnots (+ 1 / (fromIntegral numKnots - 1)) 0 - -- The control points are P(a,b,c), P(b,c,d), P(c,d,e), and so on.- controls' = zipWith mkPolarPt (extend 2 controls) (windows 3 $ extend 2 knots)+ -- The control points are P(a,b,c), P(b,c,d), P(c,d,e), and so on.+ controls' = zipWith mkPolarPt (extend 2 (NE.toList controls)) (windows 3 $ extend 2 knots) - -- The bezier internal control points are affine combinations of- -- the spline control points.- bezierControls = map combineC (windows 2 controls')- combineC [pabc, pbcd] = (combine 0 pabc pbcd, combine 1 pabc pbcd)- combineC _ = error "combineC must be called on a list of length 2"+ -- The bezier internal control points are affine combinations of+ -- the spline control points.+ bezierControls = map combineC (windows 2 controls')+ combineC (pabc :| [pbcd]) = (combine 0 pabc pbcd, combine 1 pabc pbcd)+ combineC _ = error "combineC must be called on a list of length 2" - -- The bezier end points are affine combinations of the bezier- -- control points.- bezierEnds = map combineE (windows 2 bezierControls)- combineE [(_,pabb),(pbbc,_)] = combine 0 pabb pbbc- combineE _ = error "combineE must be called on a list of length 2"+ -- The bezier end points are affine combinations of the bezier+ -- control points.+ bezierEnds = map combineE (windows 2 bezierControls)+ combineE ((_, pabb) :| [(pbbc, _)]) = combine 0 pabb pbbc+ combineE _ = error "combineE must be called on a list of length 2" - -- Finally, we actually put together the generated bezier segments.- beziers = zipWith mkBezier (drop 1 bezierControls) (windows 2 bezierEnds)- where- mkBezier (paab,pabb) [paaa,pbbb]- = FCubic (unPP paaa) (unPP paab) (unPP pabb) (unPP pbbb)- mkBezier _ _ = error "mkBezier must be called on a list of length 2"+ -- Finally, we actually put together the generated bezier segments.+ beziers = zipWith mkBezier (drop 1 bezierControls) (windows 2 bezierEnds)+ where+ mkBezier (paab, pabb) (paaa :| [pbbb]) =+ FCubic (unPP paaa) (unPP paab) (unPP pabb) (unPP pbbb)+ mkBezier _ _ = error "mkBezier must be called on a list of length 2" - -- Note that the above algorithm works in any dimension but is- -- very specific to *cubic* splines. This can of course be- -- generalized to higher degree splines but keeping track of- -- everything gets a bit more complicated; to be honest I am not- -- quite sure how to do it.+-- Note that the above algorithm works in any dimension but is+-- very specific to *cubic* splines. This can of course be+-- generalized to higher degree splines but keeping track of+-- everything gets a bit more complicated; to be honest I am not+-- quite sure how to do it. -- | Generate a uniform cubic B-spline from the given control points. -- The spline starts and ends at the first and last control points,@@ -141,9 +149,8 @@ -- > , bspline pts -- > ] -- > # frame 0.5- bspline :: (TrailLike t, V t ~ v, N t ~ n) => BSpline v n -> t bspline = fromLocSegments . fixup . map fromFixedSeg . bsplineToBeziers- where- fixup [] = [] `at` origin- fixup (b1:rest) = (unLoc b1 : map unLoc rest) `at` loc b1+ where+ fixup [] = [] `at` origin+ fixup (b1 : rest) = (unLoc b1 : map unLoc rest) `at` loc b1
src/Diagrams/CubicSpline/Internal.hs view
@@ -1,6 +1,7 @@------------------------------------------------------------------------------+{-# LANGUAGE GADTs #-}+ -- |--- Module : Diagrams.CubicSpline+-- Module : Diagrams.CubicSpline.Internal -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com@@ -9,53 +10,60 @@ -- passing through a given sequence of points. This module implements -- a straightforward spline generation algorithm based on solving -- tridiagonal systems of linear equations.----------------------------------------------------------------------------------module Diagrams.CubicSpline.Internal- (- -- * Solving for spline coefficents- solveCubicSplineDerivatives- , solveCubicSplineDerivativesClosed- , solveCubicSplineCoefficients- ) where--import Diagrams.Solve.Tridiagonal+module Diagrams.CubicSpline.Internal (+ -- * Solving for spline coefficents+ solveCubicSplineDerivatives,+ solveCubicSplineDerivativesClosed,+ solveCubicSplineCoefficients,+) where -import Data.List+import Data.List+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty.Compat as NE+import Diagrams.CubicSpline.NonSingleton (NonSingleton (..))+import qualified Diagrams.CubicSpline.NonSingleton as NS+import Diagrams.Solve.Tridiagonal -- | Use the tri-diagonal solver with the appropriate parameters for an open cubic spline.-solveCubicSplineDerivatives :: Fractional a => [a] -> [a]-solveCubicSplineDerivatives (x:xs) = solveTriDiagonal as bs as ds- where- as = replicate (l - 1) 1- bs = 2 : replicate (l - 2) 4 ++ [2]- l = length ds- ds = zipWith f (xs ++ [last xs]) (x:x:xs)- f a b = 3*(a - b)--solveCubicSplineDerivatives _ = error "argument to solveCubicSplineDerivatives must be nonempty"+--+-- See e.g. https://observablehq.com/@jrus/cubic-spline+solveCubicSplineDerivatives :: Fractional a => NonSingleton a -> NonEmpty a+solveCubicSplineDerivatives xs = solveTriDiagonal as bs as (NS.toNonEmpty ds)+ where+ as = NE.map (const 1) (NS.tail ds)+ bs = 2 :| map (const 4) (NE.tail (NS.tail ds)) ++ [2]+ -- zipWith f [x1, x2, x3, ..., xn, xn] [x0, x0, x1, ... x{n-2}, x{n-1}]+ ds = NS.zipWith f (NS.dupLast (NS.tail xs)) (NS.dupFirst xs)+ f a b = 3 * (a - b) -- | Use the cyclic-tri-diagonal solver with the appropriate parameters for a closed cubic spline.-solveCubicSplineDerivativesClosed :: Fractional a => [a] -> [a]+solveCubicSplineDerivativesClosed :: Fractional a => NonSingleton a -> NonEmpty a solveCubicSplineDerivativesClosed xs = solveCyclicTriDiagonal as bs as ds 1 1- where- as = replicate (l - 1) 1- bs = replicate l 4- l = length xs- xs' = cycle xs- ds = take l $ zipWith f (drop 1 xs') (drop (l - 1) xs')- f a b = 3*(a - b)+ where+ as = fmap (const 1) (NS.tail xs)+ bs = fmap (const 4) (NS.toNonEmpty xs) + -- zipWith f [x1, x2, x3, ..., xn, x0] [xn, x0, x1, ..., x{n-1}]+ -- ds = take l $ zipWith f (drop 1 xs') (drop (l - 1) xs') where l = length xs+ xsNE = NS.toNonEmpty xs+ ds = NE.zipWith f (NE.tail xsNE |: NE.head xsNE) (NE.cons (NE.last xsNE) xsNE)+ f a b = 3 * (a - b)++ (|:) :: [a] -> a -> NonEmpty a+ (|:) ys y = foldr NE.cons (NE.singleton y) ys+ -- | Use the cyclic-tri-diagonal solver with the appropriate parameters for a closed cubic spline.-solveCubicSplineCoefficients :: Fractional a => Bool -> [a] -> [[a]]+solveCubicSplineCoefficients :: Fractional a => Bool -> NonSingleton a -> [[a]] solveCubicSplineCoefficients closed xs =- [ [x,d,3*(x1-x)-2*d-d1,2*(x-x1)+d+d1]- | (x,x1,d,d1) <- zip4 xs' (tail xs') ds' (tail ds')- ]- where- ds | closed = solveCubicSplineDerivativesClosed xs- | otherwise = solveCubicSplineDerivatives xs- close as | closed = as ++ [head as]- | otherwise = as- xs' = close xs- ds' = close ds+ [ [x, d, 3 * (x1 - x) - 2 * d - d1, 2 * (x - x1) + d + d1]+ | (x, x1, d, d1) <- zip4 (NE.toList xs') (NE.tail xs') (NE.toList ds') (NE.tail ds')+ ]+ where+ ds+ | closed = solveCubicSplineDerivativesClosed xs+ | otherwise = solveCubicSplineDerivatives xs+ close as+ | closed = as <> NE.singleton (NE.head as)+ | otherwise = as+ xs' = close (NS.toNonEmpty xs)+ ds' = close ds
+ src/Diagrams/CubicSpline/NonSingleton.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTSyntax #-}++-- |+-- Module : Diagrams.CubicSpline.NonSingleton+-- Copyright : (c) 2026 diagrams-lib team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- A simple type representing lists with at least 2 elements, needed+-- as input for the cubic spline solver.+module Diagrams.CubicSpline.NonSingleton (+ -- * Non-singleton lists+ NonSingleton (..),+ toNonEmpty,+ tail,+ zipWith,+ dupFirst,+ dupLast,+) where++import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Prelude hiding (tail, zipWith)++-- | Lists with at least 2 elements.+data NonSingleton a where+ (:||) :: a -> NonEmpty a -> NonSingleton a+ deriving (Functor)++infixr 5 :||++toNonEmpty :: NonSingleton a -> NonEmpty a+toNonEmpty (x :|| xs) = NE.cons x xs++dupFirst :: NonSingleton a -> NonSingleton a+dupFirst (x :|| xs) = x :|| NE.cons x xs++dupLast :: NonEmpty a -> NonSingleton a+dupLast (x :| []) = x :|| (x :| [])+dupLast (x :| (y : ys)) = x :|| (y :| (ys ++ [NE.last (y :| ys)]))++zipWith :: (a -> b -> c) -> NonSingleton a -> NonSingleton b -> NonSingleton c+zipWith f (x :|| xs) (y :|| ys) = f x y :|| NE.zipWith f xs ys++tail :: NonSingleton a -> NonEmpty a+tail (_ :|| xs) = xs
src/Diagrams/Path.hs view
@@ -1,21 +1,19 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}-+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-}- -- for Data.Semigroup ------------------------------------------------------------------------------+-- for Data.Semigroup+ -- | -- Module : Diagrams.Path -- Copyright : (c) 2011 diagrams-lib team (see LICENSE)@@ -27,66 +25,56 @@ -- 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- (-- -- * Paths-- Path(..), pathTrails-- -- * Constructing paths- -- $construct-- , ToPath (..)- , pathFromTrail- , pathFromTrailAt- , pathFromLocTrail-- -- * Eliminating paths-- , pathPoints- , pathVertices'- , pathVertices- , pathOffsets- , pathCentroid- , pathLocSegments, fixPath-- -- * Modifying paths+module Diagrams.Path (+ -- * Paths+ Path (..),+ pathTrails, - , scalePath- , reversePath+ -- * Constructing paths+ -- $construct+ ToPath (..),+ pathFromTrail,+ pathFromTrailAt,+ pathFromLocTrail, - -- * Miscellaneous+ -- * Eliminating paths+ pathPoints,+ pathVertices',+ pathVertices,+ pathOffsets,+ pathCentroid,+ pathLocSegments,+ fixPath, - , explodePath- , partitionPath+ -- * Modifying paths+ scalePath,+ reversePath, - ) where+ -- * Miscellaneous+ explodePath,+ partitionPath,+) where -import Control.Arrow ((***))-import Control.Lens hiding (at, transform, ( # ))-import qualified Data.Foldable as F-import Data.List (partition)-import Data.Semigroup-import Data.Typeable+import Control.Arrow ((***))+import Control.Lens hiding (at, transform, (#))+import qualified Data.Foldable as F+import Data.List (partition)+import Data.Semigroup -import Diagrams.Align-import Diagrams.Core-import Diagrams.Located-import Diagrams.Points-import Diagrams.Segment-import Diagrams.Trail-import Diagrams.TrailLike-import Diagrams.Transform+import Diagrams.Align+import Diagrams.Core+import Diagrams.Located+import Diagrams.Points+import Diagrams.Segment+import Diagrams.Trail+import Diagrams.TrailLike+import Diagrams.Transform -import Linear.Metric-import Linear.Vector+import Linear.Metric+import Linear.Vector -import Data.Serialize (Serialize)-import GHC.Generics (Generic)+import Data.Serialize (Serialize)+import GHC.Generics (Generic) ------------------------------------------------------------ -- Paths -------------------------------------------------@@ -97,12 +85,11 @@ -- and they form a monoid under /superposition/ (placing one path on -- top of another) rather than concatenation. newtype Path v n = Path [Located (Trail v n)]- deriving (Semigroup, Monoid, Generic- , Typeable- )+ deriving (Semigroup, Monoid, Generic) -- instance (OrderedField n, Metric v, Serialize (v n), Serialize (V n (N n))) =>-instance (OrderedField n, Metric v, Serialize (v n), Serialize (V (v n) (N (v n)))) =>+instance+ (OrderedField n, Metric v, Serialize (v n), Serialize (V (v n) (N (v n)))) => Serialize (Path v n) instance Wrapped (Path v n) where@@ -130,8 +117,8 @@ pathTrails = op Path deriving instance Show (v n) => Show (Path v n)-deriving instance Eq (v n) => Eq (Path v n)-deriving instance Ord (v n) => Ord (Path v n)+deriving instance Eq (v n) => Eq (Path v n)+deriving instance Ord (v n) => Ord (Path v n) type instance V (Path v n) = v type instance N (Path v n) = n@@ -142,18 +129,21 @@ -- | Paths are trail-like; a trail can be used to construct a -- singleton path. instance (Metric v, OrderedField n) => TrailLike (Path v n) where- trailLike = Path . (:[])+ trailLike = Path . (: []) -- See Note [Transforming paths]-instance (HasLinearMap v, Metric v, OrderedField n)- => Transformable (Path v n) where+instance+ (HasLinearMap v, Metric v, OrderedField n) =>+ Transformable (Path v n)+ where transform = over _Wrapped . map . transform instance (Metric v, OrderedField n) => Enveloped (Path v n) where getEnvelope = F.foldMap trailEnvelope . op Path- -- this type signature is necessary to work around an apparent bug in ghc 6.12.1- where trailEnvelope :: Located (Trail v n) -> Envelope v n- trailEnvelope (viewLoc -> (p, t)) = moveOriginTo ((-1) *. p) (getEnvelope t)+ where+ -- this type signature is necessary to work around an apparent bug in ghc 6.12.1+ trailEnvelope :: Located (Trail v n) -> Envelope v n+ trailEnvelope (viewLoc -> (p, t)) = moveOriginTo ((-1) *. p) (getEnvelope t) instance (Metric v, OrderedField n) => Juxtaposable (Path v n) where juxtapose = juxtaposeDefault@@ -161,8 +151,10 @@ instance (Metric v, OrderedField n) => Alignable (Path v n) where defaultBoundary = envelopeBoundary -instance (HasLinearMap v, Metric v, OrderedField n)- => Renderable (Path v n) NullBackend where+instance+ (HasLinearMap v, Metric v, OrderedField n) =>+ Renderable (Path v n) NullBackend+ where render _ _ = mempty ------------------------------------------------------------@@ -174,7 +166,6 @@ -- Note that this class is very different from 'TrailLike'. 'TrailLike' is -- usually the result of a library function to give you a convenient, -- polymorphic result ('Path', 'Diagram' etc.).--- class ToPath t where -- | 'toPath' takes something that can be converted to 'Path' and returns -- the 'Path'.@@ -196,12 +187,12 @@ toPath = pathFromLocTrail . mapLoc Trail instance ToPath (Located (Segment Closed v n)) where- toPath (viewLoc -> (p,seg))- = Path [trailFromSegments [seg] `at` p]+ toPath (viewLoc -> (p, seg)) =+ Path [trailFromSegments [seg] `at` p] instance ToPath (Located [Segment Closed v n]) where- toPath (viewLoc -> (p,segs))- = Path [trailFromSegments segs `at` p]+ toPath (viewLoc -> (p, segs)) =+ Path [trailFromSegments segs `at` p] instance ToPath (FixedSegment v n) where toPath = toPath . fromFixedSeg
src/Diagrams/Prelude.hs view
@@ -1,6 +1,6 @@-{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} {-# LANGUAGE CPP #-}------------------------------------------------------------------------------+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}+ -- | -- Module : Diagrams.Prelude -- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE)@@ -9,76 +9,73 @@ -- -- A module to re-export most of the functionality of the diagrams -- core and standard library.-----------------------------------------------------------------------------------module Diagrams.Prelude- (- -- * Diagrams library- -- | Exports from this library for working with diagrams.- module Diagrams-- -- * Convenience re-exports from other packages-- -- | For working with default values. Diagrams also exports 'with',- -- an alias for 'def'.- , module Data.Default-- -- | For representing and operating on colors.- , module Data.Colour-- -- | A large list of color names.- , module Data.Colour.Names-- -- | Specify your own colours.- , module Data.Colour.SRGB-- -- | Semigroups and monoids show up all over the place, so things from- -- Data.Semigroup and Data.Monoid often come in handy.- , module Data.Semigroup-- -- | For computing with vectors.- , module Linear.Vector-- -- | For computing with points and vectors.- , module Linear.Affine+module Diagrams.Prelude (+ -- * Diagrams library - -- | For computing with dot products and norm.- , module Linear.Metric+ -- | Exports from this library for working with diagrams.+ module Diagrams, - -- | For working with 'Active' (i.e. animated) things.- , module Data.Active+ -- * Convenience re-exports from other packages - -- | Most of the lens package. The following functions are not- -- exported from lens because they either conflict with- -- diagrams or may conflict with other libraries:- --- -- * 'Control.Lens.At.at'- -- * 'Control.Lens.At.contains'- -- * 'Control.Lens.Indexed..>'- -- * 'Control.Lens.Indexed.<.>'- -- * 'Control.Lens.Indexed.index'- -- * 'Control.Lens.Indexed.indices'- -- * 'Control.Lens.Indexed.none'- -- * 'Control.Lens.Internal.Getter.coerce'- -- * 'Control.Lens.Internal.Indexed.indexed'- -- * 'Control.Lens.Lens.inside'- -- * 'Control.Lens.Level.levels'- -- * 'Control.Lens.Plated....'- -- * 'Control.Lens.Plated.children'- -- * 'Control.Lens.Plated.transform'- -- * 'Control.Lens.Prism.outside'- -- * 'Control.Lens.Setter.argument'- -- * 'Control.Lens.Traversal.beside'- -- * 'Control.Lens.Traversal.singular'- , module Control.Lens+ -- | For working with default values. Diagrams also exports 'with',+ -- an alias for 'def'.+ module Data.Default,+ -- | For representing and operating on colors.+ module Data.Colour,+ -- | A large list of color names.+ module Data.Colour.Names,+ -- | Specify your own colours.+ module Data.Colour.SRGB,+ -- | Semigroups and monoids show up all over the place, so things from+ -- Data.Semigroup and Data.Monoid often come in handy.+ module Data.Semigroup,+ -- | For computing with vectors.+ module Linear.Vector,+ -- | For computing with points and vectors.+ module Linear.Affine,+ -- | For computing with dot products and norm.+ module Linear.Metric,+ -- | For working with 'Active' (i.e. animated) things.+ module Data.Active,+ -- | Most of the lens package. The following functions are not+ -- exported from lens because they either conflict with+ -- diagrams or may conflict with other libraries:+ --+ -- * 'Control.Lens.At.at'+ -- * 'Control.Lens.At.contains'+ -- * 'Control.Lens.Indexed..>'+ -- * 'Control.Lens.Indexed.<.>'+ -- * 'Control.Lens.Indexed.index'+ -- * 'Control.Lens.Indexed.indices'+ -- * 'Control.Lens.Indexed.none'+ -- * 'Control.Lens.Internal.Getter.coerce'+ -- * 'Control.Lens.Internal.Indexed.indexed'+ -- * 'Control.Lens.Lens.inside'+ -- * 'Control.Lens.Level.levels'+ -- * 'Control.Lens.Plated....'+ -- * 'Control.Lens.Plated.children'+ -- * 'Control.Lens.Plated.transform'+ -- * 'Control.Lens.Prism.outside'+ -- * 'Control.Lens.Setter.argument'+ -- * 'Control.Lens.Traversal.beside'+ -- * 'Control.Lens.Traversal.singular'+ module Control.Lens,+ Applicative (..),+ (*>),+ (<*),+ (<$>),+ (<$),+ liftA,+ liftA2,+ liftA3,+) where - , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3- ) where+import Diagrams -import Diagrams+import Prelude.Compat+import Prelude () -import Control.Applicative+import Control.Applicative #if MIN_VERSION_lens(4,13,0) import Control.Lens hiding (argument, at, backwards, beside,@@ -93,13 +90,13 @@ (<.>)) #endif -import Data.Active-import Data.Colour hiding (AffineSpace (..), atop, over)-import Data.Colour.Names hiding (tan)-import Data.Colour.SRGB-import Data.Default-import Data.Semigroup+import Data.Active+import Data.Colour hiding (AffineSpace (..), atop, over)+import Data.Colour.Names hiding (tan)+import Data.Colour.SRGB+import Data.Default+import Data.Semigroup -import Linear.Affine-import Linear.Metric-import Linear.Vector+import Linear.Affine+import Linear.Metric+import Linear.Vector
src/Diagrams/Segment.hs view
@@ -1,19 +1,18 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ -- | -- Module : Diagrams.Segment -- Copyright : (c) 2011-2013 diagrams-lib team (see LICENSE)@@ -32,60 +31,63 @@ -- "Diagrams.Trail", "Diagrams.TrailLike", and "Diagrams.Path" should -- usually suffice. However, directly manipulating segments can -- occasionally be useful.-----------------------------------------------------------------------------------module Diagrams.Segment- ( -- * Open/closed tags-- Open, Closed-- -- * Segment offsets-- , Offset(..) , segOffset-- -- * Constructing and modifying segments-- , Segment(..), straight, bezier3, bézier3, reverseSegment, mapSegmentVectors- , openLinear, openCubic-- -- * Fixed (absolutely located) segments- , FixedSegment(..)- , mkFixedSeg, fromFixedSeg- , fixedSegIso-- -- * Segment measures- -- $segmeas-- , SegCount(..)- , ArcLength(..)- , getArcLengthCached, getArcLengthFun, getArcLengthBounded- , TotalOffset(..)- , OffsetEnvelope(..), oeOffset, oeEnvelope- , SegMeasure+module Diagrams.Segment (+ -- * Open/closed tags+ Open,+ Closed, - ) where+ -- * Segment offsets+ Offset (..),+ segOffset, -import Control.Lens hiding (at, transform)-import Data.FingerTree-import Data.Monoid.MList-import Data.Semigroup-import Numeric.Interval.Kaucher (Interval (..))-import qualified Numeric.Interval.Kaucher as I+ -- * Constructing and modifying segments+ Segment (..),+ straight,+ bezier3,+ bézier3,+ reverseSegment,+ mapSegmentVectors,+ openLinear,+ openCubic, -import Linear.Affine-import Linear.Metric-import Linear.Vector hiding (lerp)-import Linear.Vector.Compat (lerp)+ -- * Fixed (absolutely located) segments+ FixedSegment (..),+ mkFixedSeg,+ fromFixedSeg,+ fixedSegIso, -import Control.Applicative-import Diagrams.Core hiding (Measured)-import Diagrams.Located-import Diagrams.Parametric-import Diagrams.Solve.Polynomial+ -- * Segment measures+ -- $segmeas+ SegCount (..),+ ArcLength (..),+ getArcLengthCached,+ getArcLengthFun,+ getArcLengthBounded,+ TotalOffset (..),+ OffsetEnvelope (..),+ oeOffset,+ oeEnvelope,+ SegMeasure,+) where -import Data.Serialize (Serialize)-import qualified Data.Serialize as Serialize+import Control.Lens hiding (at, transform)+import Data.FingerTree+import Data.Monoid.MList+import Data.Semigroup+import Data.Serialize (Serialize)+import qualified Data.Serialize as Serialize+import Diagrams.Core hiding (Measured)+import Diagrams.Located+import Diagrams.Parametric+import Diagrams.Solve.Polynomial+import Linear.Affine+import Linear.Metric+import Linear.Vector hiding (lerp)+import Linear.Vector.Compat (lerp)+import Numeric.Interval.Kaucher (Interval (..))+import qualified Numeric.Interval.Kaucher as I+import Prelude.Compat+import Prelude () ------------------------------------------------------------ -- Open/closed type tags ---------------------------------@@ -110,32 +112,32 @@ -- /closed/ segment is stored explicitly, /i.e./ its endpoint is at -- a fixed offset from its start. data Offset c v n where- OffsetOpen :: Offset Open v n+ OffsetOpen :: Offset Open v n OffsetClosed :: v n -> Offset Closed v n deriving instance Show (v n) => Show (Offset c v n)-deriving instance Eq (v n) => Eq (Offset c v n)-deriving instance Ord (v n) => Ord (Offset c v n)+deriving instance Eq (v n) => Eq (Offset c v n)+deriving instance Ord (v n) => Ord (Offset c v n) instance Functor v => Functor (Offset c v) where- fmap _ OffsetOpen = OffsetOpen+ fmap _ OffsetOpen = OffsetOpen fmap f (OffsetClosed v) = OffsetClosed (fmap f v) instance Each (Offset c v n) (Offset c v' n') (v n) (v' n') where each f (OffsetClosed v) = OffsetClosed <$> f v- each _ OffsetOpen = pure OffsetOpen+ each _ OffsetOpen = pure OffsetOpen {-# INLINE each #-} -- | Reverses the direction of closed offsets. instance (Additive v, Num n) => Reversing (Offset c v n) where reversing (OffsetClosed off) = OffsetClosed $ negated off- reversing a@OffsetOpen = a+ reversing a@OffsetOpen = a type instance V (Offset c v n) = v type instance N (Offset c v n) = n instance Transformable (Offset c v n) where- transform _ OffsetOpen = OffsetOpen+ transform _ OffsetOpen = OffsetOpen transform t (OffsetClosed v) = OffsetClosed (apply t v) ------------------------------------------------------------@@ -150,35 +152,41 @@ -- however, affected by other transformations such as rotations and -- scales. data Segment c v n- = Linear !(Offset c v n)- -- ^ A linear segment with given offset.-- | Cubic !(v n) !(v n) !(Offset c v n)- -- ^ 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.-+ = -- | A linear segment with given offset.+ Linear !(Offset c v n)+ | -- | 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.+ Cubic !(v n) !(v n) !(Offset c v n) deriving (Functor, Eq, Ord) instance Show (v n) => Show (Segment c v n) where showsPrec d seg = case seg of- Linear (OffsetClosed v) -> showParen (d > 10) $- showString "straight " . showsPrec 11 v- Cubic v1 v2 (OffsetClosed v3) -> showParen (d > 10) $- showString "bézier3 " . showsPrec 11 v1 . showChar ' '- . showsPrec 11 v2 . showChar ' '- . showsPrec 11 v3- Linear OffsetOpen -> showString "openLinear"- Cubic v1 v2 OffsetOpen -> showParen (d > 10) $- showString "openCubic " . showsPrec 11 v1 . showChar ' '- . showsPrec 11 v2-+ Linear (OffsetClosed v) ->+ showParen (d > 10)+ $ showString "straight "+ . showsPrec 11 v+ Cubic v1 v2 (OffsetClosed v3) ->+ showParen (d > 10)+ $ showString "bézier3 "+ . showsPrec 11 v1+ . showChar ' '+ . showsPrec 11 v2+ . showChar ' '+ . showsPrec 11 v3+ Linear OffsetOpen -> showString "openLinear"+ Cubic v1 v2 OffsetOpen ->+ showParen (d > 10)+ $ showString "openCubic "+ . showsPrec 11 v1+ . showChar ' '+ . showsPrec 11 v2 instance Each (Segment c v n) (Segment c v' n') (v n) (v' n') where- each f (Linear offset) = Linear <$> each f offset- each f (Cubic v1 v2 offset) = Cubic <$> f v1 <*> f v2 <*> each f offset+ each f (Linear offset) = Linear <$> each f offset+ each f (Cubic v1 v2 offset) = Cubic <$> f v1 <*> f v2 <*> each f offset {-# INLINE each #-} -- | Reverse the direction of a segment.@@ -230,24 +238,29 @@ -- the segment for each value of the parameter between @0@ and @1@. -- It is designed to be used infix, like @seg ``atParam`` 0.5@. instance (Additive v, Num n) => Parametric (Segment Closed v n) 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+ 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 n => DomainBounds (Segment Closed v n) instance (Additive v, Num n) => EndValues (Segment Closed v n) where- atStart = const zero- atEnd (Linear (OffsetClosed v)) = v+ atStart = const zero+ 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 Closed v n -> v n-segOffset (Linear (OffsetClosed v)) = v+segOffset (Linear (OffsetClosed v)) = v segOffset (Cubic _ _ (OffsetClosed v)) = v -- | An open linear segment. This means the trail makes a straight line@@ -288,18 +301,19 @@ -- | The envelope for a segment is based at the segment's start. instance (Metric v, OrderedField n) => Enveloped (Segment Closed v n) where- getEnvelope (s@(Linear {})) = mkEnvelope $ \v ->- maximum (map (\t -> (s `atParam` t) `dot` v) [0,1]) / quadrance v-+ maximum (map (\t -> (s `atParam` t) `dot` v) [0, 1]) / quadrance v getEnvelope (s@(Cubic c1 c2 (OffsetClosed x2))) = mkEnvelope $ \v ->- maximum .- map (\t -> ((s `atParam` t) `dot` v) / quadrance v) $- [0,1] ++- filter (liftA2 (&&) (>0) (<1))- (quadForm (3 * ((3 *^ c1 ^-^ 3 *^ c2 ^+^ x2) `dot` v))- (6 * (((-2) *^ c1 ^+^ c2) `dot` v))- ((3 *^ c1) `dot` v))+ maximum+ . map (\t -> ((s `atParam` t) `dot` v) / quadrance v)+ $ [0, 1]+ ++ filter+ (liftA2 (&&) (> 0) (< 1))+ ( quadForm+ (3 * ((3 *^ c1 ^-^ 3 *^ c2 ^+^ x2) `dot` v))+ (6 * (((-2) *^ c1 ^+^ c2) `dot` v))+ ((3 *^ c1) `dot` v)+ ) ------------------------------------------------------------ -- Manipulating segments@@ -307,24 +321,26 @@ instance (Additive v, Fractional n) => Sectionable (Segment Closed v n) where splitAtParam (Linear (OffsetClosed x1)) t = (left, right)- where left = straight p- right = straight (x1 ^-^ p)- p = lerp t zero x1+ where+ left = straight p+ right = straight (x1 ^-^ p)+ p = lerp t zero x1 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 t c1 c2- a = lerp t zero c1- b = lerp t a p- d = lerp t c2 x2- c = lerp t p d- e = lerp t b c+ where+ left = bezier3 a b e+ right = bezier3 (c ^-^ e) (d ^-^ e) (x2 ^-^ e)+ p = lerp t c1 c2+ a = lerp t zero c1+ b = lerp t a p+ d = lerp t c2 x2+ c = lerp t p d+ e = lerp t b c reverseDomain = reverseSegment -- | Reverse the direction of a segment. reverseSegment :: (Num n, Additive v) => Segment Closed v n -> Segment Closed v n-reverseSegment (Linear (OffsetClosed v)) = straight (negated v)+reverseSegment (Linear (OffsetClosed v)) = straight (negated v) reverseSegment (Cubic c1 c2 (OffsetClosed x2)) = bezier3 (c2 ^-^ x2) (c1 ^-^ x2) (negated x2) -- Imitates I.elem for intervals<0.8 and I.member for intervals>=0.8@@ -332,34 +348,39 @@ member x (I.I a b) = x >= a && x <= b {-# INLINE member #-} -instance (Metric v, OrderedField n)- => HasArcLength (Segment Closed v n) where-+instance+ (Metric v, OrderedField n) =>+ HasArcLength (Segment Closed v n)+ where arcLengthBounded _ (Linear (OffsetClosed x1)) = I.singleton $ norm 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 norm [c1, c2 ^-^ c1, x2 ^-^ c2])- lb = norm x2+ | otherwise = arcLengthBounded (m / 2) l + arcLengthBounded (m / 2) r+ where+ (l, r) = s `splitAtParam` 0.5+ ub = sum (map norm [c1, c2 ^-^ c1, x2 ^-^ c2])+ lb = norm x2 arcLengthToParam m s _ | arcLength m s == 0 = 0.5 arcLengthToParam m s@(Linear {}) len = len / arcLength m s- arcLengthToParam m s@(Cubic {}) len- | len `member` I (-m/2) (m/2) = 0- | len < 0 = - arcLengthToParam m (fst (splitAtParam s (-1))) (-len)- | len `member` 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+ arcLengthToParam m s@(Cubic {}) len+ | len `member` I (-m / 2) (m / 2) = 0+ | len < 0 = -arcLengthToParam m (fst (splitAtParam s (-1))) (-len)+ | len `member` 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 - -- 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...)+-- 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@@ -370,21 +391,22 @@ -- (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 n = FLinear (Point v n) (Point v n)- | FCubic (Point v n) (Point v n) (Point v n) (Point v n)+data FixedSegment v n+ = FLinear (Point v n) (Point v n)+ | FCubic (Point v n) (Point v n) (Point v n) (Point v n) deriving (Eq, Ord, Show) type instance V (FixedSegment v n) = v type instance N (FixedSegment v n) = n instance Each (FixedSegment v n) (FixedSegment v' n') (Point v n) (Point v' n') where- each f (FLinear p0 p1) = FLinear <$> f p0 <*> f p1- each f (FCubic p0 p1 p2 p3) = FCubic <$> f p0 <*> f p1 <*> f p2 <*> f p3+ each f (FLinear p0 p1) = FLinear <$> f p0 <*> f p1+ each f (FCubic p0 p1 p2 p3) = FCubic <$> f p0 <*> f p1 <*> f p2 <*> f p3 {-# INLINE each #-} -- | Reverses the control points. instance Reversing (FixedSegment v n) where- reversing (FLinear p0 p1) = FLinear p1 p0+ reversing (FLinear p0 p1) = FLinear p1 p0 reversing (FCubic p0 p1 p2 p3) = FCubic p3 p2 p1 p0 instance (Additive v, Num n) => Transformable (FixedSegment v n) where@@ -395,15 +417,18 @@ instance (Metric v, OrderedField n) => Enveloped (FixedSegment v n) where getEnvelope f = moveTo p (getEnvelope s)- where (p, s) = viewLoc $ 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+-- 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 -instance (Metric v, OrderedField n)- => HasArcLength (FixedSegment v n) where+instance+ (Metric v, OrderedField n) =>+ HasArcLength (FixedSegment v n)+ where arcLengthBounded m s = arcLengthBounded m (fromFixedSeg s) arcLengthToParam m s = arcLengthToParam m (fromFixedSeg s) @@ -411,12 +436,12 @@ mkFixedSeg :: (Num n, Additive v) => Located (Segment Closed v n) -> FixedSegment v n mkFixedSeg ls = case viewLoc ls of- (p, Linear (OffsetClosed v)) -> FLinear p (p .+^ v)- (p, Cubic c1 c2 (OffsetClosed x2)) -> FCubic p (p .+^ c1) (p .+^ c2) (p .+^ x2)+ (p, Linear (OffsetClosed v)) -> FLinear p (p .+^ v)+ (p, Cubic c1 c2 (OffsetClosed x2)) -> FCubic p (p .+^ c1) (p .+^ c2) (p .+^ x2) -- | Convert a 'FixedSegment' back into a located 'Segment'. fromFixedSeg :: (Num n, Additive v) => FixedSegment v n -> Located (Segment Closed v n)-fromFixedSeg (FLinear p1 p2) = straight (p2 .-. p1) `at` p1+fromFixedSeg (FLinear p1 p2) = straight (p2 .-. p1) `at` p1 fromFixedSeg (FCubic x1 c1 c2 x2) = bezier3 (c1 .-. x1) (c2 .-. x1) (x2 .-. x1) `at` x1 -- | Use a 'FixedSegment' to make an 'Iso' between an@@ -429,40 +454,43 @@ instance (Additive v, Num n) => Parametric (FixedSegment v n) where atParam (FLinear p1 p2) t = lerp t p1 p2 atParam (FCubic x1 c1 c2 x2) t = p3- where p11 = lerp t x1 c1- p12 = lerp t c1 c2- p13 = lerp t c2 x2+ where+ p11 = lerp t x1 c1+ p12 = lerp t c1 c2+ p13 = lerp t c2 x2 - p21 = lerp t p11 p12- p22 = lerp t p12 p13+ p21 = lerp t p11 p12+ p22 = lerp t p12 p13 - p3 = lerp t p21 p22+ p3 = lerp t p21 p22 instance Num n => DomainBounds (FixedSegment v n) instance (Additive v, Num n) => EndValues (FixedSegment v n) where- atStart (FLinear p0 _) = p0- atStart (FCubic p0 _ _ _) = p0- atEnd (FLinear _ p1) = p1- atEnd (FCubic _ _ _ p1 ) = p1+ atStart (FLinear p0 _) = p0+ atStart (FCubic p0 _ _ _) = p0+ atEnd (FLinear _ p1) = p1+ atEnd (FCubic _ _ _ p1) = p1 instance (Additive v, Fractional n) => Sectionable (FixedSegment v n) where splitAtParam (FLinear p0 p1) t = (left, right)- where left = FLinear p0 p- right = FLinear p p1- p = lerp t p0 p1+ where+ left = FLinear p0 p+ right = FLinear p p1+ p = lerp t p0 p1 splitAtParam (FCubic p0 c1 c2 p1) t = (left, right)- where left = FCubic p0 a b cut- right = FCubic cut c d p1- -- first round- a = lerp t p0 c1- p = lerp t c1 c2- d = lerp t c2 p1- -- second round- b = lerp t a p- c = lerp t p d- -- final round- cut = lerp t b c+ where+ left = FCubic p0 a b cut+ right = FCubic cut c d p1+ -- first round+ a = lerp t p0 c1+ p = lerp t c1 c2+ d = lerp t c2 p1+ -- second round+ b = lerp t a p+ c = lerp t p d+ -- final round+ cut = lerp t b c reverseDomain (FLinear p0 p1) = FLinear p1 p0 reverseDomain (FCubic p0 c1 c2 p1) = FCubic p1 c2 c1 p0@@ -490,7 +518,6 @@ -- 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 n = ArcLength (Sum (Interval n), n -> Sum (Interval n)) @@ -513,15 +540,17 @@ -- | 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 n, Ord n)- => n -> ArcLength n -> Interval n+getArcLengthBounded ::+ (Num n, Ord n) =>+ n -> ArcLength n -> Interval n getArcLengthBounded eps al | I.width cached <= eps = cached- | otherwise = getArcLengthFun al eps- where- cached = getArcLengthCached al+ | otherwise = getArcLengthFun al eps+ where+ cached = getArcLengthCached al+ deriving instance (Num n, Ord n) => Semigroup (ArcLength n)-deriving instance (Num n, Ord n) => Monoid (ArcLength n)+deriving instance (Num n, Ord n) => Monoid (ArcLength n) -- | A type to represent the total cumulative offset of a chain of -- segments.@@ -537,7 +566,7 @@ TotalOffset v1 <> TotalOffset v2 = TotalOffset (v1 ^+^ v2) instance (Num n, Additive v) => Monoid (TotalOffset v n) where- mempty = TotalOffset zero+ mempty = TotalOffset zero mappend = (<>) -- | A type to represent the offset and envelope of a chain of@@ -545,58 +574,65 @@ -- combining the envelopes of two consecutive chains needs to take -- the offset of the first into account. data OffsetEnvelope v n = OffsetEnvelope- { _oeOffset :: !(TotalOffset v n)+ { _oeOffset :: !(TotalOffset v n) , _oeEnvelope :: Envelope v n } makeLenses ''OffsetEnvelope instance (Metric v, OrderedField n) => Semigroup (OffsetEnvelope v n) where- (OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 e2)- = let !negOff = negated . op TotalOffset $ o1- e2Off = moveOriginBy negOff e2- !_unused = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off- in OffsetEnvelope+ (OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 e2) =+ let !negOff = negated . op TotalOffset $ o1+ e2Off = moveOriginBy negOff e2+ !_unused = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off+ in OffsetEnvelope (o1 <> o2) (e1 <> e2Off) -- | @SegMeasure@ collects up all the measurements over a chain of -- segments.-type SegMeasure v n = SegCount- ::: ArcLength n- ::: OffsetEnvelope v n- ::: ()- -- unfortunately we can't cache Trace, since there is not a generic- -- instance Traced (Segment Closed v), only Traced (Segment Closed R2).--instance (Metric v, OrderedField n)- => Measured (SegMeasure v n) (SegMeasure v n) where- measure = id--instance (OrderedField n, Metric v)- => Measured (SegMeasure v n) (Segment Closed v n) where- measure s = (SegCount . Sum) 1+type SegMeasure v n =+ SegCount+ ::: ArcLength n+ ::: OffsetEnvelope v n+ ::: () - -- 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 )+-- unfortunately we can't cache Trace, since there is not a generic+-- instance Traced (Segment Closed v), only Traced (Segment Closed R2). - *: OffsetEnvelope (TotalOffset . segOffset $ s)- (getEnvelope s)+instance+ (Metric v, OrderedField n) =>+ Measured (SegMeasure v n) (SegMeasure v n)+ where+ measure = id - *: ()+instance+ (OrderedField n, Metric v) =>+ Measured (SegMeasure v n) (Segment Closed v n)+ 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)+ *: () ------------------------------------------------------------ -- Serialize instances ------------------------------------------------------------ -instance (Serialize (v n)) => Serialize (Segment Open v n) where+instance Serialize (v n) => Serialize (Segment Open v n) where {-# INLINE put #-} put segment = case segment of- Linear OffsetOpen -> Serialize.put True+ Linear OffsetOpen -> Serialize.put True Cubic v w OffsetOpen -> do Serialize.put False Serialize.put v@@ -606,16 +642,16 @@ get = do isLinear <- Serialize.get case isLinear of- True -> return (Linear OffsetOpen)+ True -> return (Linear OffsetOpen) False -> do v <- Serialize.get w <- Serialize.get return (Cubic v w OffsetOpen) -instance (Serialize (v n)) => Serialize (Segment Closed v n) where+instance Serialize (v n) => Serialize (Segment Closed v n) where {-# INLINE put #-} put segment = case segment of- Linear (OffsetClosed z) -> do+ Linear (OffsetClosed z) -> do Serialize.put z Serialize.put True Cubic v w (OffsetClosed z) -> do@@ -629,7 +665,7 @@ z <- Serialize.get isLinear <- Serialize.get case isLinear of- True -> return (Linear (OffsetClosed z))+ True -> return (Linear (OffsetClosed z)) False -> do v <- Serialize.get w <- Serialize.get
src/Diagrams/Size.hs view
@@ -1,17 +1,19 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-} -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module : Diagrams.Size -- Copyright : (c) 2014 diagrams-lib team (see LICENSE)@@ -19,45 +21,42 @@ -- Maintainer : diagrams-discuss@googlegroups.com -- -- Utilities for working with sizes of objects.----------------------------------------------------------------------------------module Diagrams.Size- ( -- * Size spec- SizeSpec+module Diagrams.Size (+ -- * Size spec+ SizeSpec, - -- ** Making size spec- , mkSizeSpec- , dims- , absolute+ -- ** Making size spec+ mkSizeSpec,+ dims,+ absolute, - -- ** Extracting size specs- , getSpec- , specToSize+ -- ** Extracting size specs+ getSpec,+ specToSize, - -- ** Functions on size specs- , requiredScale- , requiredScaling- , sized- , sizedAs- , sizeAdjustment- ) where+ -- ** Functions on size specs+ requiredScale,+ requiredScaling,+ sized,+ sizedAs,+ sizeAdjustment,+) where -import Control.Applicative-import Control.Lens hiding (transform)-import Control.Monad-import Data.Foldable as F-import Data.Hashable-import Data.Maybe-import Data.Semigroup-import Data.Typeable-import GHC.Generics (Generic)-import Prelude+import Control.Applicative+import Control.Lens hiding (transform)+import Control.Monad+import Data.Foldable as F+import Data.Hashable+import Data.Maybe+import Data.Semigroup+import GHC.Generics (Generic)+import Prelude -import Diagrams.BoundingBox-import Diagrams.Core+import Diagrams.BoundingBox+import Diagrams.Core -import Linear.Affine-import Linear.Vector+import Linear.Affine+import Linear.Vector ------------------------------------------------------------ -- Computing diagram sizes@@ -66,13 +65,13 @@ -- | A 'SizeSpec' is a way of specifying a size without needed lengths for all -- the dimensions. newtype SizeSpec v n = SizeSpec (v n)- deriving (- Eq,- Typeable,- Functor,- Generic,- Hashable,- Show)+ deriving+ ( Eq+ , Functor+ , Generic+ , Hashable+ , Show+ ) type instance V (SizeSpec v n) = v type instance N (SizeSpec v n) = n@@ -80,7 +79,7 @@ -- | Retrieve a size spec as a vector of maybe values. Only positive sizes are -- returned. getSpec :: (Functor v, Num n, Ord n) => SizeSpec v n -> v (Maybe n)-getSpec (SizeSpec sp) = mfilter (>0) . Just <$> sp+getSpec (SizeSpec sp) = mfilter (> 0) . Just <$> sp -- | Make a 'SizeSpec' from a vector of maybe values. Any negative values will -- be ignored. For 2D 'SizeSpec's see 'mkWidth' and 'mkHeight' from@@ -102,56 +101,67 @@ -- used. specToSize :: (Foldable v, Functor v, Num n, Ord n) => n -> SizeSpec v n -> v n specToSize n (getSpec -> spec) = fmap (fromMaybe smallest) spec- where- smallest = fromMaybe n $ minimumOf (folded . _Just) spec+ where+ smallest = fromMaybe n $ minimumOf (folded . _Just) spec -- | @requiredScale spec sz@ returns the largest scaling factor to make -- something of size @sz@ fit the requested size @spec@ without changing the -- aspect ratio. @sz@ should be non-zero (otherwise a scale of 1 is -- returned). For non-uniform scaling see 'boxFit'.-requiredScale :: (Additive v, Foldable v, Fractional n, Ord n)- => SizeSpec v n -> v n -> n+requiredScale ::+ (Additive v, Foldable v, Fractional n, Ord n) =>+ SizeSpec v n -> v n -> n requiredScale (getSpec -> spec) sz | allOf (folded . _Just) (<= 0) usedSz = 1- | otherwise = fromMaybe 1 mScale- where- usedSz = liftI2 (<$) sz spec- scales = liftI2 (^/) spec sz- mScale = minimumOf (folded . _Just) scales+ | otherwise = fromMaybe 1 mScale+ where+ usedSz = liftI2 (<$) sz spec+ scales = liftI2 (^/) spec sz+ mScale = minimumOf (folded . _Just) scales -- | Return the 'Transformation' calcuated from 'requiredScale'.-requiredScaling :: (Additive v, Foldable v, Fractional n, Ord n)- => SizeSpec v n -> v n -> Transformation v n+requiredScaling ::+ (Additive v, Foldable v, Fractional n, Ord n) =>+ SizeSpec v n -> v n -> Transformation v n requiredScaling spec = scaling . requiredScale spec -- | Uniformly scale any enveloped object so that it fits within the -- given size. For non-uniform scaling see 'boxFit'.-sized :: (InSpace v n a, HasLinearMap v, Transformable a, Enveloped a)- => SizeSpec v n -> a -> a+sized ::+ (InSpace v n a, HasLinearMap v, Transformable a, Enveloped a) =>+ SizeSpec v n -> a -> a sized spec a = transform (requiredScaling spec (size a)) a -- | Uniformly scale an enveloped object so that it \"has the same -- size as\" (fits within the width and height of) some other -- object.-sizedAs :: (InSpace v n a, SameSpace a b, HasLinearMap v, Transformable a,- Enveloped a, Enveloped b)- => b -> a -> a+sizedAs ::+ ( InSpace v n a+ , SameSpace a b+ , HasLinearMap v+ , Transformable a+ , Enveloped a+ , Enveloped b+ ) =>+ b -> a -> a sizedAs other = sized (dims $ size other) -- | Get the adjustment to fit a 'BoundingBox' in the given 'SizeSpec'. The -- vector is the new size and the transformation to position the lower -- corner at the origin and scale to the size spec.-sizeAdjustment :: (Additive v, Foldable v, OrderedField n)- => SizeSpec v n -> BoundingBox v n -> (v n, Transformation v n)+sizeAdjustment ::+ (Additive v, Foldable v, OrderedField n) =>+ SizeSpec v n -> BoundingBox v n -> (v n, Transformation v n) sizeAdjustment spec bb = (sz', t)- where- v = (0.5 *^ P sz') .-. (s *^ fromMaybe origin (boxCenter bb))+ where+ v = (0.5 *^ P sz') .-. (s *^ fromMaybe origin (boxCenter bb)) - sz = boxExtents bb- sz' = if allOf folded isJust (getSpec spec)- then specToSize 0 spec- else s *^ sz+ sz = boxExtents bb+ sz' =+ if allOf folded isJust (getSpec spec)+ then specToSize 0 spec+ else s *^ sz - s = requiredScale spec sz+ s = requiredScale spec sz - t = translation v <> scaling s+ t = translation v <> scaling s
src/Diagrams/ThreeD/Attributes.hs view
@@ -29,7 +29,6 @@ import Control.Lens import Data.Semigroup-import Data.Typeable import Data.Colour @@ -38,7 +37,7 @@ -- | @SurfaceColor@ is the inherent pigment of an object, assumed to -- be opaque. newtype SurfaceColor = SurfaceColor (Last (Colour Double))- deriving (Typeable, Semigroup, Show)+ deriving (Semigroup, Show) instance AttributeClass SurfaceColor @@ -59,7 +58,7 @@ -- Attribute. For physical reasonableness, @Diffuse@ should have a -- value between 0 and 1; this is not checked. newtype Diffuse = Diffuse (Last Double)- deriving (Typeable, Semigroup, Show)+ deriving (Semigroup, Show) instance AttributeClass Diffuse @@ -82,7 +81,7 @@ -- indirect lighting incident on that object and the diffuse -- reflectance. newtype Ambient = Ambient (Last Double)- deriving (Typeable, Semigroup, Show)+ deriving (Semigroup, Show) instance AttributeClass Ambient @@ -112,7 +111,7 @@ makeLenses ''Specular newtype Highlight = Highlight (Last Specular)- deriving (Typeable, Semigroup, Show)+ deriving (Semigroup, Show) instance AttributeClass Highlight
src/Diagrams/ThreeD/Camera.hs view
@@ -49,7 +49,6 @@ , up :: V3 n , lens :: l n }- deriving Typeable type instance V (Camera l n) = V3 type instance N (Camera l n) = n@@ -63,7 +62,6 @@ { _horizontalFieldOfView :: Angle n -- ^ Horizontal field of view. , _verticalFieldOfView :: Angle n -- ^ Vertical field of view. }- deriving Typeable makeLenses ''PerspectiveLens @@ -78,7 +76,6 @@ { _orthoWidth :: n -- ^ Width , _orthoHeight :: n -- ^ Height }- deriving Typeable makeLenses ''OrthoLens
src/Diagrams/ThreeD/Light.hs view
@@ -29,7 +29,6 @@ -- | A @PointLight@ radiates uniformly in all directions from a given -- point. data PointLight n = PointLight (Point V3 n) (Colour Double)- deriving Typeable type instance V (PointLight n) = V3 type instance N (PointLight n) = n@@ -37,7 +36,6 @@ -- | A @ParallelLight@ casts parallel rays in the specified direction, -- from some distant location outside the scene. data ParallelLight n = ParallelLight (V3 n) (Colour Double)- deriving Typeable type instance V (ParallelLight n) = V3 type instance N (ParallelLight n) = n
src/Diagrams/ThreeD/Shapes.hs view
@@ -42,7 +42,6 @@ ) where import Control.Lens (review, (^.), _1)-import Data.Typeable import Data.Semigroup import Diagrams.Angle@@ -59,7 +58,6 @@ import Linear.Vector data Ellipsoid n = Ellipsoid (Transformation V3 n)- deriving Typeable type instance V (Ellipsoid n) = V3 type instance N (Ellipsoid n) = n@@ -86,7 +84,6 @@ sphere = Ellipsoid mempty data Box n = Box (Transformation V3 n)- deriving Typeable type instance V (Box n) = V3 type instance N (Box n) = n@@ -124,7 +121,6 @@ cube = Box mempty data Frustum n = Frustum n n (Transformation V3 n)- deriving Typeable type instance V (Frustum n) = V3 type instance N (Frustum n) = n@@ -235,7 +231,6 @@ | CsgUnion [CSG n] | CsgIntersection [CSG n] | CsgDifference (CSG n) (CSG n)- deriving Typeable type instance V (CSG n) = V3 type instance N (CSG n) = n
src/Diagrams/Trail.hs view
@@ -1,1386 +1,1529 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}--- We have an orphan Transformable FingerTree instance here.---------------------------------------------------------------------------------- |--- Module : Diagrams.Trail--- Copyright : (c) 2013-2015 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(..)- , _Line, _Loop- , _LocLine, _LocLoop- , wrapTrail, wrapLine, wrapLoop- , onTrail, onLine-- , glueTrail, closeTrail, cutTrail-- -- * Constructing trails-- , emptyLine, emptyTrail- , lineFromVertices, trailFromVertices- , lineFromOffsets, trailFromOffsets- , lineFromSegments, trailFromSegments- , loopFromSegments-- -- * Eliminating trails-- , withTrail', withTrail, withLine- , isLineEmpty, isTrailEmpty- , isLine, isLoop- , trailSegments, lineSegments, loopSegments- , onLineSegments- , trailOffsets, trailOffset- , lineOffsets, lineOffset, loopOffsets- , trailPoints, linePoints, loopPoints- , trailVertices', lineVertices', loopVertices'- , trailVertices, lineVertices, loopVertices- , trailLocSegments, fixTrail, unfixTrail-- -- * Modifying trails-- , reverseTrail, reverseLocTrail- , reverseLine, reverseLocLine- , reverseLoop, reverseLocLoop-- -- * Internals- -- $internals-- -- ** Type tags-- , Line, Loop-- -- ** Segment trees-- , SegTree(..), trailMeasure, numSegs, offset-- -- ** Extracting segments-- , GetSegment(..), getSegment, GetSegmentCodomain(..)-- ) where--import Control.Arrow ((***))-import Control.Lens hiding (at, transform, (<|), (|>))-import Data.FingerTree (FingerTree, ViewL (..), ViewR (..),- viewl, (<|), (|>))-import qualified Data.FingerTree as FT-import Data.Fixed-import qualified Data.Foldable as F-import Data.Monoid.MList-import Data.Semigroup-import qualified Numeric.Interval.Kaucher as I--import Diagrams.Core-import Diagrams.Located-import Diagrams.Parametric-import Diagrams.Segment-import Diagrams.Tangent--import Linear.Affine-import Linear.Metric-import Linear.Vector--import Data.Serialize (Serialize)-import qualified Data.Serialize as Serialize---- $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-type instance N (FingerTree m a) = N a--instance (FT.Measured m a, Transformable a)- => Transformable (FingerTree m a) where- transform = FT.fmap' . transform--instance (FT.Measured m a, FT.Measured n b)- => Cons (FingerTree m a) (FingerTree n b) a b where- _Cons = prism (uncurry (FT.<|)) $ \aas -> case FT.viewl aas of- a FT.:< as -> Right (a, as)- EmptyL -> Left mempty- {-# INLINE _Cons #-}--instance (FT.Measured m a, FT.Measured n b)- => Snoc (FingerTree m a) (FingerTree n b) a b where- _Snoc = prism (uncurry (FT.|>)) $ \aas -> case FT.viewr aas of- as FT.:> a -> Right (as, a)- EmptyR -> Left mempty- {-# INLINE _Snoc #-}----------------------------------------------------------------- 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 n = SegTree (FingerTree (SegMeasure v n) (Segment Closed v n))- deriving (Eq, Ord, Show, Monoid, Transformable, FT.Measured (SegMeasure v n))---- Only derive the Semigroup instance for versions of base that--- include Semigroup. This is because the fingertree package has--- similar CPP to only export a Semigroup instance for those versions--- of base, so for GHC 7.10 and earlier we get a 'no instance found'--- error when trying to derive the Semigroup instance for SegTree. It--- would also be possible to depend on the 'semigroups' package in--- order to get the Semigroup class regardless of base version, but--- presumably fingertree didn't want to add a dependency.-#if MIN_VERSION_base(4,9,0)-deriving instance (Ord n, Floating n, Metric v) => Semigroup (SegTree v n)-#endif--instance Wrapped (SegTree v n) where- type Unwrapped (SegTree v n) = FingerTree (SegMeasure v n) (Segment Closed v n)- _Wrapped' = iso (\(SegTree x) -> x) SegTree- {-# INLINE _Wrapped' #-}--instance (Metric v, OrderedField n, Metric u, OrderedField n')- => Cons (SegTree v n) (SegTree u n') (Segment Closed v n) (Segment Closed u n') where- _Cons = _Wrapped . _Cons . bimapping id _Unwrapped- {-# INLINE _Cons #-}--instance (Metric v, OrderedField n, Metric u, OrderedField n')- => Snoc (SegTree v n) (SegTree u n') (Segment Closed v n) (Segment Closed u n') where- _Snoc = _Wrapped . _Snoc . bimapping _Unwrapped id- {-# INLINE _Snoc #-}--instance Rewrapped (SegTree v n) (SegTree v' n')--type instance V (SegTree v n) = v-type instance N (SegTree v n) = n--type instance Codomain (SegTree v n) = v--instance (Metric v, OrderedField n, Real n)- => Parametric (SegTree v n) where- atParam t p = offset . fst $ splitAtParam t p--instance Num n => DomainBounds (SegTree v n)--instance (Metric v, OrderedField n, Real n)- => EndValues (SegTree v n)--splitAtParam' :: (Metric v, OrderedField n, Real n)- => SegTree v n -> n -> ((SegTree v n, SegTree v n), n -> n)-splitAtParam' (SegTree t) p- | tSegs == 0 = ((mempty , mempty ), id)- | otherwise = ((SegTree treeL, SegTree treeR), rescale)- where- tSegs = numSegs t- splitParam q | q < 0 = (0 , q * tSegs)- | q >= 1 = (tSegs - 1, 1 + (q - 1) * tSegs)- | otherwise = propFrac $ q * tSegs- where propFrac x = let m = mod1 x in (x - m, m)- (pSegs, pParam) = splitParam p- (before, viewl -> seg FT.:< after) = FT.split ((pSegs <) . numSegs) t- (segL, segR) = seg `splitAtParam` pParam- (treeL, treeR) | pParam == 0 = (before , seg <| after)- | pParam == 1 = (before |> seg , after)- | otherwise = (before |> segL, segR <| after)- -- section uses rescale to find the new value of p1 after the split at p2- rescale u | pSegs' == uSegs = (uSegs + uParam / pParam' {-'1-}) / (pSegs' + 1) {-'2-}- | otherwise = u * tSegs / (pSegs' + 1) {-'3-}- where- -- param 0 on a segment is param 1 on the previous segment- (pSegs', pParam') | pParam == 0 = (pSegs-1, 1)- | otherwise = (pSegs , pParam)- (uSegs , uParam ) = splitParam u- -- '1 (pParam ≠ 0 → pParam' = pParam) ∧ (pParam = 0 → pParam' = 1) → pParam' ≠ 0- -- '2 uSegs ≥ 0 ∧ pSegs' = uSegs → pSegs' ≥ 0 → pSegs' + 1 > 0- -- '3 pSegs' + 1 = 0 → pSegs' = -1 → pSegs = 0 ∧ pParam = 0 → p = 0- -- → rescale is not called--instance (Metric v, OrderedField n, Real n) => Sectionable (SegTree v n) where- splitAtParam tree p = fst $ splitAtParam' tree p-- reverseDomain (SegTree t) = SegTree $ FT.reverse t'- where t' = FT.fmap' reverseSegment t-- section x p1 p2 | p2 == 0 = reverseDomain . fst $ splitAtParam x p1- | p1 <= p2 = let ((a, _), rescale) = splitAtParam' x p2- in snd $ splitAtParam a (rescale p1)- | otherwise = reverseDomain $ section x p2 p1--instance (Metric v, OrderedField n, Real n)- => HasArcLength (SegTree v n) 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- t- fun = trailMeasure (const 0)- getArcLengthFun- t-- arcLengthToParam eps st@(SegTree t) l- | l < 0 = case FT.viewl t of- EmptyL -> 0- seg FT.:< _ -> arcLengthToParam eps seg l / tSegs- | l >= totalAL = case FT.viewr t of- EmptyR -> 0- t' FT.:> 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 FT.:< _ ->- 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 n) (Segment Closed v n)- (before, after) =- FT.split ((>= l)- . trailMeasure- 0- (I.midpoint . getArcLengthBounded eps))- 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 :: ( SegMeasure v n :>: m, FT.Measured (SegMeasure v n) t )- => a -> (m -> a) -> t -> a-trailMeasure d f = maybe d f . get . FT.measure---- | Compute the number of segments of anything measured by--- 'SegMeasure' (/e.g./ @SegMeasure@ itself, @Segment@, @SegTree@,--- @Trail@s...)-numSegs :: (Num c, FT.Measured (SegMeasure v n) a)- => a -> c-numSegs = fromIntegral . trailMeasure 0 (getSum . op SegCount)---- | Compute the total offset of anything measured by 'SegMeasure'.-offset :: ( OrderedField n, Metric v,- FT.Measured (SegMeasure v n) t- )- => t -> v n-offset = trailMeasure zero (op TotalOffset . view 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 n where- Line :: SegTree v n -> Trail' Line v n- Loop :: SegTree v n -> Segment Open v n -> Trail' Loop v n---- | A generic eliminator for 'Trail'', taking functions specifying--- what to do in the case of a line or a loop.-withTrail' :: (Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail' l v n -> r-withTrail' line _ t@(Line{}) = line t-withTrail' _ loop t@(Loop{}) = loop t--deriving instance Eq (v n) => Eq (Trail' l v n)-deriving instance Ord (v n) => Ord (Trail' l v n)--instance Show (v n) => Show (Trail' l v n) where- showsPrec d (Line (SegTree ft)) = showParen (d > 10) $- showString "lineFromSegments " . showList (F.toList ft)-- showsPrec d (Loop (SegTree ft) o) = showParen (d > 10) $- showString "loopFromSegments " . showList (F.toList ft) .- showChar ' ' . showsPrec 11 o--type instance V (Trail' l v n) = v-type instance N (Trail' l v n) = n--type instance Codomain (Trail' l v n) = v--instance (OrderedField n, Metric v) => Semigroup (Trail' Line v n) 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 (Metric v, OrderedField n) => Monoid (Trail' Line v n) where- mempty = emptyLine- mappend = (<>)--instance (Metric v, OrderedField n) => AsEmpty (Trail' Line v n) where- _Empty = nearly emptyLine isLineEmpty--instance (HasLinearMap v, Metric v, OrderedField n)- => Transformable (Trail' l v n) 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 (Metric v, OrderedField n) => Enveloped (Trail' l v n) where- getEnvelope = withTrail' ftEnv (ftEnv . cutLoop)- where- ftEnv :: Trail' Line v n -> Envelope v n- ftEnv (Line t) = trailMeasure mempty (view oeEnvelope) t--instance (HasLinearMap v, Metric v, OrderedField n)- => Renderable (Trail' o v n) NullBackend where- render _ _ = mempty--instance (Metric v, OrderedField n, Real n)- => Parametric (Trail' l v n) where- atParam t p = withTrail'- (\(Line segT) -> segT `atParam` p)- (\l -> cutLoop l `atParam` mod1 p)- t--instance (Parametric (GetSegment (Trail' c v n)), Additive v, Num n)- => Parametric (Tangent (Trail' c v n)) where- Tangent tr `atParam` p =- case GetSegment tr `atParam` p of- GetSegmentCodomain Nothing -> zero- GetSegmentCodomain (Just (_, seg, reparam)) -> Tangent seg `atParam` (p ^. cloneIso reparam)--instance ( Parametric (GetSegment (Trail' c v n))- , EndValues (GetSegment (Trail' c v n))- , Additive v- , Num n- )- => EndValues (Tangent (Trail' c v n)) where- atStart (Tangent tr) =- case atStart (GetSegment tr) of- GetSegmentCodomain Nothing -> zero- GetSegmentCodomain (Just (_, seg, _)) -> atStart (Tangent seg)- atEnd (Tangent tr) =- case atEnd (GetSegment tr) of- GetSegmentCodomain Nothing -> zero- GetSegmentCodomain (Just (_, seg, _)) -> atEnd (Tangent seg)--instance (Metric v , OrderedField n, Real n)- => Parametric (Tangent (Trail v n)) where- Tangent tr `atParam` p- = withTrail- ((`atParam` p) . Tangent)- ((`atParam` p) . Tangent)- tr--instance (Metric v, OrderedField n, Real n)- => EndValues (Tangent (Trail v n)) where- atStart (Tangent tr) = withTrail (atStart . Tangent) (atStart . Tangent) tr- atEnd (Tangent tr) = withTrail (atEnd . Tangent) (atEnd . Tangent) tr---- | Compute the remainder mod 1. Convenient for constructing loop--- parameterizations that wrap around.-mod1 :: Real a => a -> a-mod1 = (`mod'` 1)--instance Num n => DomainBounds (Trail' l v n)--instance (Metric v, OrderedField n, Real n)- => EndValues (Trail' l v n)--instance (Metric v, OrderedField n, Real n)- => Sectionable (Trail' Line v n) where- splitAtParam (Line t) p = (Line t1, Line t2)- where- (t1, t2) = splitAtParam t p-- section (Line t) p1 p2 = Line (section t p1 p2)-- reverseDomain = reverseLine--instance (Metric v, OrderedField n, Real n)- => HasArcLength (Trail' l v n) 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--instance Rewrapped (Trail' Line v n) (Trail' Line v' n')-instance Wrapped (Trail' Line v n) where- type Unwrapped (Trail' Line v n) = SegTree v n- _Wrapped' = iso (\(Line x) -> x) Line- {-# INLINE _Wrapped' #-}--instance (Metric v, OrderedField n, Metric u, OrderedField n')- => Cons (Trail' Line v n) (Trail' Line u n') (Segment Closed v n) (Segment Closed u n') where- _Cons = _Wrapped . _Cons . bimapping id _Unwrapped- {-# INLINE _Cons #-}--instance (Metric v, OrderedField n, Metric u, OrderedField n')- => Snoc (Trail' Line v n) (Trail' Line u n') (Segment Closed v n) (Segment Closed u n') where- _Snoc = _Wrapped . _Snoc . bimapping _Unwrapped id- {-# INLINE _Snoc #-}---- | Compose two Located trails by adding a segment joining the endpoint--- of the first to the starting point of the second. Note, if you have--- two located trails such that the end of the first coincides with the--- start of the second, this will still add a trivial zero-length segment--- between them; in that case you are probably better off with something--- like @mapLoc (<> unLoc t2) t1@.-instance (Real n, Floating n, Metric v)- => Semigroup (Located (Trail' Line v n)) where- a@(Loc aLoc aLine) <> b@(Loc _ bLine) =- Loc aLoc (aLine <> lineFromOffsets [atStart b .-. atEnd a] <> bLine)------------------------------------------------------- Extracting segments---- | A newtype wrapper around trails which exists solely for its--- 'Parametric', 'DomainBounds' and 'EndValues' instances. The idea--- is that if @tr@ is a trail, you can write, /e.g./------ @--- getSegment tr `atParam` 0.6--- @------ or------ @--- atStart (getSegment tr)--- @------ to get the segment at parameter 0.6 or the first segment in the--- trail, respectively.------ The codomain for 'GetSegment', /i.e./ the result you get from--- calling 'atParam', 'atStart', or 'atEnd', is--- 'GetSegmentCodomain', which is a newtype wrapper around @Maybe--- (v, Segment Closed v, AnIso' n n)@. @Nothing@ results if the--- trail is empty; otherwise, you get:------ * the offset from the start of the trail to the beginning of the--- segment,------ * the segment itself, and------ * a reparameterization isomorphism: in the forward direction, it--- translates from parameters on the whole trail to a parameters--- on the segment. Note that for technical reasons you have to--- call 'cloneIso' on the @AnIso'@ value to get a real isomorphism--- you can use.-newtype GetSegment t = GetSegment t--newtype GetSegmentCodomain v n =- GetSegmentCodomain- (Maybe ( v n -- offset from trail start to segment start- , Segment Closed v n -- the segment- , AnIso' n n -- reparameterization, trail <-> segment- ))---- | Create a 'GetSegment' wrapper around a trail, after which you can--- call 'atParam', 'atStart', or 'atEnd' to extract a segment.-getSegment :: t -> GetSegment t-getSegment = GetSegment--type instance V (GetSegment t) = V t-type instance N (GetSegment t) = N t--type instance Codomain (GetSegment t) = GetSegmentCodomain (V t)---- | Parameters less than 0 yield the first segment; parameters--- greater than 1 yield the last. A parameter exactly at the--- junction of two segments yields the second segment (/i.e./ the--- one with higher parameter values).-instance (Metric v, OrderedField n) => Parametric (GetSegment (Trail' Line v n)) where- atParam (GetSegment (Line (SegTree ft))) p- | p <= 0 = case FT.viewl ft of- EmptyL -> GetSegmentCodomain Nothing- seg FT.:< _ -> GetSegmentCodomain $ Just (zero, seg, reparam 0)-- | p >= 1 = case FT.viewr ft of- EmptyR -> GetSegmentCodomain Nothing- ft' FT.:> seg -> GetSegmentCodomain $ Just (offset ft', seg, reparam (n-1))-- | otherwise- = let (before, after) = FT.split ((p*n <) . numSegs) ft- in case FT.viewl after of- EmptyL -> GetSegmentCodomain Nothing- seg FT.:< _ -> GetSegmentCodomain $ Just (offset before, seg, reparam (numSegs before))- where- n = numSegs ft- reparam k = iso (subtract k . (*n))- ((/n) . (+ k))---- | The parameterization for loops wraps around, /i.e./ parameters--- are first reduced \"mod 1\".-instance (Metric v, OrderedField n, Real n) => Parametric (GetSegment (Trail' Loop v n)) where- atParam (GetSegment l) p = atParam (GetSegment (cutLoop l)) (mod1 p)--instance (Metric v, OrderedField n, Real n)- => Parametric (GetSegment (Trail v n)) where- atParam (GetSegment t) p- = withTrail- ((`atParam` p) . GetSegment)- ((`atParam` p) . GetSegment)- t--instance DomainBounds t => DomainBounds (GetSegment t) where- domainLower (GetSegment t) = domainLower t- domainUpper (GetSegment t) = domainUpper t--instance (Metric v, OrderedField n)- => EndValues (GetSegment (Trail' Line v n)) where- atStart (GetSegment (Line (SegTree ft)))- = case FT.viewl ft of- EmptyL -> GetSegmentCodomain Nothing- seg FT.:< _ ->- let n = numSegs ft- in GetSegmentCodomain $ Just (zero, seg, iso (*n) (/n))-- atEnd (GetSegment (Line (SegTree ft)))- = case FT.viewr ft of- EmptyR -> GetSegmentCodomain Nothing- ft' FT.:> seg ->- let n = numSegs ft- in GetSegmentCodomain $- Just (offset ft', seg, iso (subtract (n-1) . (*n))- ((/n) . (+ (n-1)))- )--instance (Metric v, OrderedField n, Real n)- => EndValues (GetSegment (Trail' Loop v n)) where- atStart (GetSegment l) = atStart (GetSegment (cutLoop l))- atEnd (GetSegment l) = atEnd (GetSegment (cutLoop l))--instance (Metric v, OrderedField n, Real n)- => EndValues (GetSegment (Trail v n)) where- atStart (GetSegment t)- = withTrail- (atStart . GetSegment)- (atStart . GetSegment)- t- atEnd (GetSegment t)- = withTrail- (atEnd . GetSegment)- (atEnd . GetSegment)- t------------------------------------------------------- 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 n where- Trail :: Trail' l v n -> Trail v n--deriving instance Show (v n) => Show (Trail v n)--instance Eq (v n) => Eq (Trail v n) where- t1 == t2 =- withTrail- (\ln1 -> withTrail (\ln2 -> ln1 == ln2) (const False) t2)- (\lp1 -> withTrail (const False) (\lp2 -> lp1 == lp2) t2)- t1--instance Ord (v n) => Ord (Trail v n) where- compare t1 t2 =- withTrail- (\ln1 -> withTrail (compare ln1) (const LT) t2)- (\lp1 -> withTrail (const GT) (compare lp1) 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 n, Metric v) => Semigroup (Trail v n) 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 (Metric v, OrderedField n) => Monoid (Trail v n) where- mempty = wrapLine emptyLine- mappend = (<>)--instance (Metric v, OrderedField n) => AsEmpty (Trail v n) where- _Empty = nearly emptyTrail isTrailEmpty--type instance V (Trail v n) = v-type instance N (Trail v n) = n--type instance Codomain (Trail v n) = v--instance (HasLinearMap v, Metric v, OrderedField n)- => Transformable (Trail v n) where- transform t = onTrail (transform t) (transform t)--instance (Metric v, OrderedField n) => Enveloped (Trail v n) where- getEnvelope = withTrail getEnvelope getEnvelope--instance (Metric v, OrderedField n, Real n)- => Parametric (Trail v n) where- atParam t p = withTrail (`atParam` p) (`atParam` p) t--instance Num n => DomainBounds (Trail v n)--instance (Metric v, OrderedField n, Real n) => EndValues (Trail v n)---- | 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 (Metric v, OrderedField n, Real n) => Sectionable (Trail v n) where- splitAtParam t p = withLine ((wrapLine *** wrapLine) . (`splitAtParam` p)) t-- section t p1 p2 = withLine (wrapLine . (\l -> section l p1 p2)) t-- reverseDomain = reverseTrail--instance (Metric v, OrderedField n, Real n)- => HasArcLength (Trail v n) where- arcLengthBounded = withLine . arcLengthBounded- arcLengthToParam eps tr al = withLine (\ln -> arcLengthToParam eps ln al) tr---- lens instrances --------------------------------------------------------- | Prism onto a 'Line'.-_Line :: Prism' (Trail v n) (Trail' Line v n)-_Line = _Wrapped' . _Left---- | Prism onto a 'Loop'.-_Loop :: Prism' (Trail v n) (Trail' Loop v n)-_Loop = _Wrapped' . _Right---- | Prism onto a 'Located' 'Line'.-_LocLine :: Prism' (Located (Trail v n)) (Located (Trail' Line v n))-_LocLine = prism' (mapLoc Trail) $ located (preview _Line)---- | Prism onto a 'Located' 'Loop'.-_LocLoop :: Prism' (Located (Trail v n)) (Located (Trail' Loop v n))-_LocLoop = prism' (mapLoc Trail) $ located (preview _Loop)--instance Rewrapped (Trail v n) (Trail v' n')-instance Wrapped (Trail v n) where- type Unwrapped (Trail v n) = Either (Trail' Line v n) (Trail' Loop v n)- _Wrapped' = iso getTrail (either Trail Trail)- where- getTrail :: Trail v n -> Either (Trail' Line v n) (Trail' Loop v n)- getTrail (Trail t@(Line {})) = Left t- getTrail (Trail t@(Loop {})) = Right t------------------------------------------------------- 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 n -> r) -> (Trail' Loop v n -> r) -> Trail v n -> 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 n -> Trail' l1 v n) -> (Trail' Loop v n -> Trail' l2 v n)- -> Trail v n -> Trail v n-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 :: (Metric v, OrderedField n)- => (Trail' Line v n -> r) -> Trail v n -> 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 :: (Metric v, OrderedField n)- => (Trail' Line v n -> Trail' Line v n) -> Trail v n -> Trail v n-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 n -> Trail v n-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 n -> Trail v n-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 n -> Trail v n-wrapLoop = wrapTrail----------------------------------------------------------------- Constructing trails ---------------------------------------------------------------------------------------------------- | The empty line, which is the identity for concatenation of lines.-emptyLine :: (Metric v, OrderedField n) => Trail' Line v n-emptyLine = Line mempty---- | A wrapped variant of 'emptyLine'.-emptyTrail :: (Metric v, OrderedField n) => Trail v n-emptyTrail = wrapLine emptyLine---- | Construct a line from a list of closed segments.-lineFromSegments :: (Metric v, OrderedField n)- => [Segment Closed v n] -> Trail' Line v n-lineFromSegments = Line . SegTree . FT.fromList---- | Construct a loop from a list of closed segments and an open segment--- that completes the loop.-loopFromSegments :: (Metric v, OrderedField n)- => [Segment Closed v n] -> Segment Open v n -> Trail' Loop v n-loopFromSegments segs = Loop (SegTree (FT.fromList segs))---- | @trailFromSegments === 'wrapTrail' . 'lineFromSegments'@, for--- conveniently constructing a @Trail@ instead of a @Trail'@.-trailFromSegments :: (Metric v, OrderedField n)- => [Segment Closed v n] -> Trail v n-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'.------ <<diagrams/src_Diagrams_Trail_lineFromOffsetsEx.svg#diagram=lineFromOffsetsEx&width=300>>------ > import Diagrams.Coordinates--- > lineFromOffsetsEx = strokeLine $ lineFromOffsets [ 2 ^& 1, 2 ^& (-1), 2 ^& 0.5 ]-lineFromOffsets :: (Metric v, OrderedField n) => [v n] -> Trail' Line v n-lineFromOffsets = lineFromSegments . map straight---- | @trailFromOffsets === 'wrapTrail' . 'lineFromOffsets'@, for--- conveniently constructing a @Trail@ instead of a @Trail' Line@.-trailFromOffsets :: (Metric v, OrderedField n) => [v n] -> Trail v n-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)@.------ <<diagrams/src_Diagrams_Trail_lineFromVerticesEx.svg#diagram=lineFromVerticesEx&width=300>>------ > import Diagrams.Coordinates--- > lineFromVerticesEx = pad 1.1 . centerXY . strokeLine--- > $ lineFromVertices [origin, 0 ^& 1, 1 ^& 2, 5 ^& 1]-lineFromVertices :: (Metric v, OrderedField n)- => [Point v n] -> Trail' Line v n-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 :: (Metric v, OrderedField n)- => [Point v n] -> Trail v n-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.------ <<diagrams/src_Diagrams_Trail_glueLineEx.svg#diagram=glueLineEx&width=500>>------ > glueLineEx = pad 1.1 . hsep 1--- > $ [almostClosed # strokeLine, almostClosed # glueLine # strokeLoop]--- >--- > almostClosed :: Trail' Line V2 Double--- > almostClosed = fromOffsets $ map r2 [(2, -1), (-3, -0.5), (-2, 1), (1, 0.5)]------ @glueLine@ is left inverse to 'cutLoop', that is,------ @--- glueLine . cutLoop === id--- @-glueLine :: (Metric v, OrderedField n) => Trail' Line v n -> Trail' Loop v n-glueLine (Line (SegTree t)) =- case FT.viewr t of- FT.EmptyR -> Loop mempty (Linear OffsetOpen)- t' FT.:> Linear _ -> Loop (SegTree t') (Linear OffsetOpen)- t' FT.:> 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 :: (Metric v, OrderedField n) => Trail v n -> Trail v n-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--- @------ <<diagrams/src_Diagrams_Trail_closeLineEx.svg#diagram=closeLineEx&width=500>>------ > closeLineEx = pad 1.1 . centerXY . hcat' (with & sep .~ 1)--- > $ [almostClosed # strokeLine, almostClosed # closeLine # strokeLoop]-closeLine :: Trail' Line v n -> Trail' Loop v n-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 n -> Trail v n-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 n. (Metric v, OrderedField n)- => Trail' Loop v n -> Trail' Line v n-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 n- offV = negated . trailMeasure zero (op TotalOffset .view 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 :: (Metric v, OrderedField n)- => Trail v n -> Trail v n-cutTrail = onTrail id cutLoop----------------------------------------------------------------- Eliminating trails ----------------------------------------------------------------------------------------------------- | Test whether a line is empty.-isLineEmpty :: (Metric v, OrderedField n) => Trail' Line v n -> Bool-isLineEmpty (Line (SegTree t)) = FT.null t---- | Test whether a trail is empty. Note that loops are never empty.-isTrailEmpty :: (Metric v, OrderedField n) => Trail v n -> Bool-isTrailEmpty = withTrail isLineEmpty (const False)---- | Determine whether a trail is a line.-isLine :: Trail v n -> Bool-isLine = not . isLoop---- | Determine whether a trail is a loop.-isLoop :: Trail v n -> Bool-isLoop = withTrail (const False) (const True)---- | Extract the segments comprising a line.-lineSegments :: Trail' Line v n -> [Segment Closed v n]-lineSegments (Line (SegTree t)) = F.toList t---- | Modify a line by applying a function to its list of segments.-onLineSegments- :: (Metric v, OrderedField n)- => ([Segment Closed v n] -> [Segment Closed v n])- -> Trail' Line v n -> Trail' Line v n-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 n -> ([Segment Closed v n], Segment Open v n)-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 :: (Metric v, OrderedField n)- => Trail v n -> [Segment Closed v n]-trailSegments = withLine lineSegments---- | Extract the offsets of the segments of a trail.-trailOffsets :: (Metric v, OrderedField n) => Trail v n -> [v n]-trailOffsets = withLine lineOffsets---- | Compute the offset from the start of a trail to the end. Satisfies------ @--- trailOffset === sumV . trailOffsets--- @------ but is more efficient.------ <<diagrams/src_Diagrams_Trail_trailOffsetEx.svg#diagram=trailOffsetEx&width=300>>------ > trailOffsetEx = (strokeLine almostClosed <> showOffset) # centerXY # pad 1.1--- > where showOffset = fromOffsets [trailOffset (wrapLine almostClosed)]--- > # strokeP # lc red-trailOffset :: (Metric v, OrderedField n) => Trail v n -> v n-trailOffset = withLine lineOffset---- | Extract the offsets of the segments of a line.-lineOffsets :: Trail' Line v n -> [v n]-lineOffsets = map segOffset . lineSegments---- | Extract the offsets of the segments of a loop.-loopOffsets :: (Metric v, OrderedField n) => Trail' Loop v n -> [v n]-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 :: (Metric v, OrderedField n) => Trail' Line v n -> v n-lineOffset (Line t) = trailMeasure zero (op TotalOffset . view oeOffset) t---- | Extract the points of a concretely located trail, /i.e./ the points--- where one segment ends and the next begins. Note that for loops,--- the starting point 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 point at the start--- and end, /e.g./ with @trailPoints . mapLoc cutTrail@.------ Note that it does not make sense to ask for the points of a--- 'Trail' by itself; if you want the points of a trail--- with the first point at, say, the origin, you can use--- @trailPoints . (\`at\` origin)@.------ This function allows you "observe" the fact that trails are--- implemented as lists of segments, which may be problematic if we--- want to think of trails as parametric vector functions. This also--- means that the behavior of this function may not be stable under--- future changes to the implementation of trails. For an--- unproblematic version which only yields vertices at which there--- is a sharp corner, excluding points where the trail is--- differentiable, see 'trailVertices'.------ This function is not re-exported from "Diagrams.Prelude"; to use--- it, import "Diagrams.Trail".-trailPoints :: (Metric v, OrderedField n)- => Located (Trail v n) -> [Point v n]-trailPoints (viewLoc -> (p,t))- = withTrail (linePoints . (`at` p)) (loopPoints . (`at` p)) t---- | Extract the segment join points of a concretely located line. See--- 'trailPoints' for more information.------ This function allows you "observe" the fact that lines are--- implemented as lists of segments, which may be problematic if we--- want to think of lines as parametric vector functions. This also--- means that the behavior of this function may not be stable under--- future changes to the implementation of trails. For an--- unproblematic version which only yields vertices at which there--- is a sharp corner, excluding points where the trail is--- differentiable, see 'lineVertices'.------ This function is not re-exported from "Diagrams.Prelude"; to use--- it, import "Diagrams.Trail".-linePoints :: (Metric v, OrderedField n)- => Located (Trail' Line v n) -> [Point v n]-linePoints (viewLoc -> (p,t))- = segmentPoints p . lineSegments $ t---- | Extract the segment join points of a concretely located loop. Note that the--- initial vertex is not repeated at the end. See 'trailPoints' for--- more information.------ This function allows you "observe" the fact that lines are--- implemented as lists of segments, which may be problematic if we--- want to think of lines as parametric vector functions. This also--- means that the behavior of this function may not be stable under--- future changes to the implementation of trails. For an--- unproblematic version which only yields vertices at which there--- is a sharp corner, excluding points where the trail is--- differentiable, see 'lineVertices'.------ This function is not re-exported from "Diagrams.Prelude"; to use--- it, import "Diagrams.Trail".-loopPoints :: (Metric v, OrderedField n)- => Located (Trail' Loop v n) -> [Point v n]-loopPoints (viewLoc -> (p,t))- = segmentPoints p . fst . loopSegments $ t--segmentPoints :: (Additive v, Num n) => Point v n -> [Segment Closed v n] -> [Point v n]-segmentPoints p = scanl (.+^) p . map segOffset--tolerance :: OrderedField a => a-tolerance = 10e-16---- | Extract the vertices of a concretely located trail. Here a /vertex/--- is defined as a non-differentiable point on the trail, /i.e./ a--- sharp corner. (Vertices are thus a subset of the places where--- segments join; if you want all joins between segments, see--- 'trailPoints'.) The tolerance determines how close the tangents--- of two segments must be at their endpoints to consider the--- transition point to be differentiable.------ 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@.------ 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' :: (Metric v, OrderedField n)- => n -> Located (Trail v n) -> [Point v n]-trailVertices' toler (viewLoc -> (p,t))- = withTrail (lineVertices' toler . (`at` p)) (loopVertices' toler . (`at` p)) t---- | Like 'trailVertices'', with a default tolerance.-trailVertices :: (Metric v, OrderedField n)- => Located (Trail v n) -> [Point v n]-trailVertices = trailVertices' tolerance---- | Extract the vertices of a concretely located line. See--- 'trailVertices' for more information.-lineVertices' :: (Metric v, OrderedField n)- => n -> Located (Trail' Line v n) -> [Point v n]-lineVertices' toler (viewLoc -> (p,t))- = segmentVertices' toler p . lineSegments $ t---- | Like 'lineVertices'', with a default tolerance.-lineVertices :: (Metric v, OrderedField n)- => Located (Trail' Line v n) -> [Point v n]-lineVertices = lineVertices' tolerance---- | 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' :: (Metric v, OrderedField n)- => n -> Located (Trail' Loop v n) -> [Point v n]-loopVertices' toler (viewLoc -> (p,t))- | length segs > 1 = if far > toler then init ps else init . drop 1 $ ps- | otherwise = ps- where- far = quadrance ((signorm . tangentAtStart . head $ segs) ^-^- (signorm . tangentAtEnd . last $ segs))- segs = lineSegments . cutLoop $ t- ps = segmentVertices' toler p segs---- | Same as 'loopVertices'', with a default tolerance.-loopVertices :: (Metric v, OrderedField n)- => Located (Trail' Loop v n) -> [Point v n]-loopVertices = loopVertices' tolerance---- | The vertices of a list of segments laid end to end.--- The start and end points are always included in the list of--- vertices. The other points connecting segments are included if--- the slope at the end of a segment is not equal to the slope at--- the beginning of the next. The 'toler' parameter is used to--- control how close the slopes need to be in order to declare them--- equal.-segmentVertices' :: (Metric v, OrderedField n)- => n -> Point v n -> [Segment Closed v n] -> [Point v n]-segmentVertices' toler p ts =- case ps of- (x:_:_) -> x : select (drop 1 ps) ds ++ [last ps]- _ -> ps- where- ds = zipWith far tans (drop 1 tans)- tans = [(signorm . tangentAtStart $ s- ,signorm . tangentAtEnd $ s) | s <- ts]- ps = scanl (.+^) p . map segOffset $ ts- far p2 q2 = quadrance (snd p2 ^-^ fst q2) > toler--select :: [a] -> [Bool] -> [a]-select xs bs = map fst $ filter snd (zip xs bs)---- | Convert a concretely located trail into a list of fixed segments.--- 'unfixTrail' is almost its left inverse.-fixTrail :: (Metric v, OrderedField n)- => Located (Trail v n) -> [FixedSegment v n]-fixTrail t = map mkFixedSeg (trailLocSegments t)---- | Convert a list of fixed segments into a located trail. Note that--- this may lose information: it throws away the locations of all--- but the first @FixedSegment@. This does not matter precisely--- when each @FixedSegment@ begins where the previous one ends.------ This is almost left inverse to 'fixTrail', that is, @unfixTrail--- . fixTrail == id@, except for the fact that @unfixTrail@ will--- never yield a @Loop@. In the case of a loop, we instead have--- @glueTrail . unfixTrail . fixTrail == id@. On the other hand, it--- is not the case that @fixTrail . unfixTrail == id@ since--- @unfixTrail@ may lose information.-unfixTrail- :: (Metric v, Ord n, Floating n)- => [FixedSegment v n] -> Located (Trail v n)-unfixTrail = mapLoc trailFromSegments . takeLoc . map fromFixedSeg- where- takeLoc [] = [] `at` origin- takeLoc xs@(x:_) = map unLoc xs `at` loc x---- | Convert a concretely located trail into a list of located segments.-trailLocSegments :: (Metric v, OrderedField n)- => Located (Trail v n) -> [Located (Segment Closed v n)]-trailLocSegments t = zipWith at (trailSegments (unLoc t)) (trailPoints 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 :: (Metric v, OrderedField n) => Trail v n -> Trail v n-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 :: (Metric v, OrderedField n)- => Located (Trail v n) -> Located (Trail v n)-reverseLocTrail (viewLoc -> (p, t)) = reverseTrail t `at` (p .+^ trailOffset t)---- | Reverse a line. See 'reverseTrail'.-reverseLine :: (Metric v, OrderedField n)- => Trail' Line v n -> Trail' Line v n-reverseLine = onLineSegments (reverse . map reverseSegment)---- | Reverse a concretely located line. See 'reverseLocTrail'.-reverseLocLine :: (Metric v, OrderedField n)- => Located (Trail' Line v n) -> Located (Trail' Line v n)-reverseLocLine (viewLoc -> (p,l)) = reverseLine l `at` (p .+^ lineOffset l)---- | Reverse a loop. See 'reverseTrail'.-reverseLoop :: (Metric v, OrderedField n)- => Trail' Loop v n -> Trail' Loop v n-reverseLoop = glueLine . reverseLine . cutLoop---- | Reverse a concretely located loop. See 'reverseLocTrail'. Note--- that this is guaranteed to preserve the location.-reverseLocLoop :: (Metric v, OrderedField n)- => Located (Trail' Loop v n) -> Located (Trail' Loop v n)-reverseLocLoop = mapLoc reverseLoop---- | Same as 'reverseLine' or 'reverseLoop'.-instance (Metric v, OrderedField n) => Reversing (Trail' l v n) where- reversing t@(Line _) = onLineSegments (reverse . map reversing) t- reversing t@(Loop _ _) = glueLine . reversing . cutLoop $ t---- | Same as 'reverseTrail'.-instance (Metric v, OrderedField n) => Reversing (Trail v n) where- reversing (Trail t) = Trail (reversing t)---- | Same as 'reverseLocLine' or 'reverseLocLoop'.-instance (Metric v, OrderedField n) => Reversing (Located (Trail' l v n)) where- reversing l@(Loc _ Line {}) = reverseLocLine l- reversing l@(Loc _ Loop {}) = reverseLocLoop l---- | Same as 'reverseLocTrail'.-instance (Metric v, OrderedField n) => Reversing (Located (Trail v n)) where- reversing = reverseLocTrail----------------------------------------------------------------- Serialize instances---------------------------------------------------------------instance (Serialize (v n), OrderedField n, Metric v) => Serialize (Trail v n) where- {-# INLINE get #-}- get = do- isLine <- Serialize.get- case isLine of- True -> do- segTree <- Serialize.get- return (Trail (Line segTree))- False -> do- segTree <- Serialize.get- segment <- Serialize.get- return (Trail (Loop segTree segment))-- {-# INLINE put #-}- put (Trail (Line segTree)) = do- Serialize.put True- Serialize.put segTree-+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- We have an orphan Transformable FingerTree instance here.++-- |+-- Module : Diagrams.Trail+-- Copyright : (c) 2013-2015 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 (..),+ _Line,+ _Loop,+ _LocLine,+ _LocLoop,+ wrapTrail,+ wrapLine,+ wrapLoop,+ onTrail,+ onLine,+ glueTrail,+ closeTrail,+ cutTrail,++ -- * Constructing trails+ emptyLine,+ emptyTrail,+ lineFromVertices,+ trailFromVertices,+ lineFromOffsets,+ trailFromOffsets,+ lineFromSegments,+ trailFromSegments,+ loopFromSegments,++ -- * Eliminating trails+ withTrail',+ withTrail,+ withLine,+ isLineEmpty,+ isTrailEmpty,+ isLine,+ isLoop,+ trailSegments,+ lineSegments,+ loopSegments,+ onLineSegments,+ trailOffsets,+ trailOffset,+ lineOffsets,+ lineOffset,+ loopOffsets,+ trailPoints,+ linePoints,+ loopPoints,+ trailVertices',+ lineVertices',+ loopVertices',+ trailVertices,+ lineVertices,+ loopVertices,+ trailLocSegments,+ fixTrail,+ unfixTrail,++ -- * Modifying trails+ reverseTrail,+ reverseLocTrail,+ reverseLine,+ reverseLocLine,+ reverseLoop,+ reverseLocLoop,++ -- * Internals+ -- $internals++ -- ** Type tags+ Line,+ Loop,++ -- ** Segment trees+ SegTree (..),+ trailMeasure,+ numSegs,+ offset,++ -- ** Extracting segments+ GetSegment (..),+ getSegment,+ GetSegmentCodomain (..),+) where++import Control.Arrow ((***))+import Control.Lens hiding (at, transform, (<|), (|>))+import Data.FingerTree (+ FingerTree,+ ViewL (..),+ ViewR (..),+ viewl,+ (<|),+ (|>),+ )+import qualified Data.FingerTree as FT+import Data.Fixed+import qualified Data.Foldable as F+import qualified Data.List.NonEmpty as NE+import Data.Monoid.MList+import Data.Semigroup+import qualified Numeric.Interval.Kaucher as I++import Diagrams.Core+import Diagrams.Located+import Diagrams.Parametric+import Diagrams.Segment+import Diagrams.Tangent++import Linear.Affine+import Linear.Metric+import Linear.Vector++import Data.Serialize (Serialize)+import qualified Data.Serialize as Serialize++-- $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+type instance N (FingerTree m a) = N a++instance+ (FT.Measured m a, Transformable a) =>+ Transformable (FingerTree m a)+ where+ transform = FT.fmap' . transform++instance+ (FT.Measured m a, FT.Measured n b) =>+ Cons (FingerTree m a) (FingerTree n b) a b+ where+ _Cons = prism (uncurry (FT.<|)) $ \aas -> case FT.viewl aas of+ a FT.:< as -> Right (a, as)+ EmptyL -> Left mempty+ {-# INLINE _Cons #-}++instance+ (FT.Measured m a, FT.Measured n b) =>+ Snoc (FingerTree m a) (FingerTree n b) a b+ where+ _Snoc = prism (uncurry (FT.|>)) $ \aas -> case FT.viewr aas of+ as FT.:> a -> Right (as, a)+ EmptyR -> Left mempty+ {-# INLINE _Snoc #-}++------------------------------------------------------------+-- 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 n = SegTree (FingerTree (SegMeasure v n) (Segment Closed v n))+ deriving (Eq, Ord, Show, Monoid, Transformable, FT.Measured (SegMeasure v n), Semigroup)++instance Wrapped (SegTree v n) where+ type Unwrapped (SegTree v n) = FingerTree (SegMeasure v n) (Segment Closed v n)+ _Wrapped' = iso (\(SegTree x) -> x) SegTree+ {-# INLINE _Wrapped' #-}++instance+ (Metric v, OrderedField n, Metric u, OrderedField n') =>+ Cons (SegTree v n) (SegTree u n') (Segment Closed v n) (Segment Closed u n')+ where+ _Cons = _Wrapped . _Cons . bimapping id _Unwrapped+ {-# INLINE _Cons #-}++instance+ (Metric v, OrderedField n, Metric u, OrderedField n') =>+ Snoc (SegTree v n) (SegTree u n') (Segment Closed v n) (Segment Closed u n')+ where+ _Snoc = _Wrapped . _Snoc . bimapping _Unwrapped id+ {-# INLINE _Snoc #-}++instance Rewrapped (SegTree v n) (SegTree v' n')++type instance V (SegTree v n) = v+type instance N (SegTree v n) = n++type instance Codomain (SegTree v n) = v++instance+ (Metric v, OrderedField n, Real n) =>+ Parametric (SegTree v n)+ where+ atParam t p = offset . fst $ splitAtParam t p++instance Num n => DomainBounds (SegTree v n)++instance+ (Metric v, OrderedField n, Real n) =>+ EndValues (SegTree v n)++splitAtParam' ::+ (Metric v, OrderedField n, Real n) =>+ SegTree v n -> n -> ((SegTree v n, SegTree v n), n -> n)+splitAtParam' (SegTree t) p+ | tSegs == 0 = ((mempty, mempty), id)+ | otherwise = ((SegTree treeL, SegTree treeR), rescale)+ where+ tSegs = numSegs t+ splitParam q+ | q < 0 = (0, q * tSegs)+ | q >= 1 = (tSegs - 1, 1 + (q - 1) * tSegs)+ | otherwise = propFrac $ q * tSegs+ where+ propFrac x = let m = mod1 x in (x - m, m)+ (pSegs, pParam) = splitParam p+ (before, seg, after) = case FT.split ((pSegs <) . numSegs) t of+ (before, rest) -> case viewl rest of+ EmptyL -> (before, Linear (OffsetClosed zero), rest)+ seg FT.:< after -> (before, seg, after)+ (segL, segR) = seg `splitAtParam` pParam+ (treeL, treeR)+ | pParam == 0 = (before, seg <| after)+ | pParam == 1 = (before |> seg, after)+ | otherwise = (before |> segL, segR <| after)+ -- section uses rescale to find the new value of p1 after the split at p2+ rescale u+ | pSegs' == uSegs = (uSegs + uParam / pParam' {-'1-}) / (pSegs' + 1 {-'2-})+ | otherwise = u * tSegs / (pSegs' + 1 {-'3-})+ where+ -- param 0 on a segment is param 1 on the previous segment+ (pSegs', pParam')+ | pParam == 0 = (pSegs - 1, 1)+ | otherwise = (pSegs, pParam)+ (uSegs, uParam) = splitParam u++-- '1 (pParam ≠ 0 → pParam' = pParam) ∧ (pParam = 0 → pParam' = 1) → pParam' ≠ 0+-- '2 uSegs ≥ 0 ∧ pSegs' = uSegs → pSegs' ≥ 0 → pSegs' + 1 > 0+-- '3 pSegs' + 1 = 0 → pSegs' = -1 → pSegs = 0 ∧ pParam = 0 → p = 0+-- → rescale is not called++instance (Metric v, OrderedField n, Real n) => Sectionable (SegTree v n) where+ splitAtParam tree p = fst $ splitAtParam' tree p++ reverseDomain (SegTree t) = SegTree $ FT.reverse t'+ where+ t' = FT.fmap' reverseSegment t++ section x p1 p2+ | p2 == 0 = reverseDomain . fst $ splitAtParam x p1+ | p1 <= p2 =+ let ((a, _), rescale) = splitAtParam' x p2+ in snd $ splitAtParam a (rescale p1)+ | otherwise = reverseDomain $ section x p2 p1++instance+ (Metric v, OrderedField n, Real n) =>+ HasArcLength (SegTree v n)+ 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+ t+ fun =+ trailMeasure+ (const 0)+ getArcLengthFun+ t++ arcLengthToParam eps st@(SegTree t) l+ | l < 0 = case FT.viewl t of+ EmptyL -> 0+ seg FT.:< _ -> arcLengthToParam eps seg l / tSegs+ | l >= totalAL = case FT.viewr t of+ EmptyR -> 0+ t' FT.:> 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 FT.:< _ ->+ 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 n) (Segment Closed v n)+ (before, after) =+ FT.split+ ( (>= l)+ . trailMeasure+ 0+ (I.midpoint . getArcLengthBounded eps)+ )+ 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 ::+ (SegMeasure v n :>: m, FT.Measured (SegMeasure v n) t) =>+ a -> (m -> a) -> t -> a+trailMeasure d f = maybe d f . get . FT.measure++-- | Compute the number of segments of anything measured by+-- 'SegMeasure' (/e.g./ @SegMeasure@ itself, @Segment@, @SegTree@,+-- @Trail@s...)+numSegs ::+ (Num c, FT.Measured (SegMeasure v n) a) =>+ a -> c+numSegs = fromIntegral . trailMeasure 0 (getSum . op SegCount)++-- | Compute the total offset of anything measured by 'SegMeasure'.+offset ::+ ( OrderedField n+ , Metric v+ , FT.Measured (SegMeasure v n) t+ ) =>+ t -> v n+offset = trailMeasure zero (op TotalOffset . view 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 n where+ Line :: SegTree v n -> Trail' Line v n+ Loop :: SegTree v n -> Segment Open v n -> Trail' Loop v n++-- | A generic eliminator for 'Trail'', taking functions specifying+-- what to do in the case of a line or a loop.+withTrail' :: (Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail' l v n -> r+withTrail' line _ t@(Line {}) = line t+withTrail' _ loop t@(Loop {}) = loop t++deriving instance Eq (v n) => Eq (Trail' l v n)+deriving instance Ord (v n) => Ord (Trail' l v n)++instance Show (v n) => Show (Trail' l v n) where+ showsPrec d (Line (SegTree ft)) =+ showParen (d > 10) $+ showString "lineFromSegments " . showList (F.toList ft)+ showsPrec d (Loop (SegTree ft) o) =+ showParen (d > 10) $+ showString "loopFromSegments "+ . showList (F.toList ft)+ . showChar ' '+ . showsPrec 11 o++type instance V (Trail' l v n) = v+type instance N (Trail' l v n) = n++type instance Codomain (Trail' l v n) = v++instance (OrderedField n, Metric v) => Semigroup (Trail' Line v n) 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 (Metric v, OrderedField n) => Monoid (Trail' Line v n) where+ mempty = emptyLine+ mappend = (<>)++instance (Metric v, OrderedField n) => AsEmpty (Trail' Line v n) where+ _Empty = nearly emptyLine isLineEmpty++instance+ (HasLinearMap v, Metric v, OrderedField n) =>+ Transformable (Trail' l v n)+ 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 (Metric v, OrderedField n) => Enveloped (Trail' l v n) where+ getEnvelope = withTrail' ftEnv (ftEnv . cutLoop)+ where+ ftEnv :: Trail' Line v n -> Envelope v n+ ftEnv (Line t) = trailMeasure mempty (view oeEnvelope) t++instance+ (HasLinearMap v, Metric v, OrderedField n) =>+ Renderable (Trail' o v n) NullBackend+ where+ render _ _ = mempty++instance+ (Metric v, OrderedField n, Real n) =>+ Parametric (Trail' l v n)+ where+ atParam t p =+ withTrail'+ (\(Line segT) -> segT `atParam` p)+ (\l -> cutLoop l `atParam` mod1 p)+ t++instance+ (Parametric (GetSegment (Trail' c v n)), Additive v, Num n) =>+ Parametric (Tangent (Trail' c v n))+ where+ Tangent tr `atParam` p =+ case GetSegment tr `atParam` p of+ GetSegmentCodomain Nothing -> zero+ GetSegmentCodomain (Just (_, seg, reparam)) -> Tangent seg `atParam` (p ^. cloneIso reparam)++instance+ ( Parametric (GetSegment (Trail' c v n))+ , EndValues (GetSegment (Trail' c v n))+ , Additive v+ , Num n+ ) =>+ EndValues (Tangent (Trail' c v n))+ where+ atStart (Tangent tr) =+ case atStart (GetSegment tr) of+ GetSegmentCodomain Nothing -> zero+ GetSegmentCodomain (Just (_, seg, _)) -> atStart (Tangent seg)+ atEnd (Tangent tr) =+ case atEnd (GetSegment tr) of+ GetSegmentCodomain Nothing -> zero+ GetSegmentCodomain (Just (_, seg, _)) -> atEnd (Tangent seg)++instance+ (Metric v, OrderedField n, Real n) =>+ Parametric (Tangent (Trail v n))+ where+ Tangent tr `atParam` p =+ withTrail+ ((`atParam` p) . Tangent)+ ((`atParam` p) . Tangent)+ tr++instance+ (Metric v, OrderedField n, Real n) =>+ EndValues (Tangent (Trail v n))+ where+ atStart (Tangent tr) = withTrail (atStart . Tangent) (atStart . Tangent) tr+ atEnd (Tangent tr) = withTrail (atEnd . Tangent) (atEnd . Tangent) tr++-- | Compute the remainder mod 1. Convenient for constructing loop+-- parameterizations that wrap around.+mod1 :: Real a => a -> a+mod1 = (`mod'` 1)++instance Num n => DomainBounds (Trail' l v n)++instance+ (Metric v, OrderedField n, Real n) =>+ EndValues (Trail' l v n)++instance+ (Metric v, OrderedField n, Real n) =>+ Sectionable (Trail' Line v n)+ where+ splitAtParam (Line t) p = (Line t1, Line t2)+ where+ (t1, t2) = splitAtParam t p++ section (Line t) p1 p2 = Line (section t p1 p2)++ reverseDomain = reverseLine++instance+ (Metric v, OrderedField n, Real n) =>+ HasArcLength (Trail' l v n)+ 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++instance Rewrapped (Trail' Line v n) (Trail' Line v' n')+instance Wrapped (Trail' Line v n) where+ type Unwrapped (Trail' Line v n) = SegTree v n+ _Wrapped' = iso (\(Line x) -> x) Line+ {-# INLINE _Wrapped' #-}++instance+ (Metric v, OrderedField n, Metric u, OrderedField n') =>+ Cons (Trail' Line v n) (Trail' Line u n') (Segment Closed v n) (Segment Closed u n')+ where+ _Cons = _Wrapped . _Cons . bimapping id _Unwrapped+ {-# INLINE _Cons #-}++instance+ (Metric v, OrderedField n, Metric u, OrderedField n') =>+ Snoc (Trail' Line v n) (Trail' Line u n') (Segment Closed v n) (Segment Closed u n')+ where+ _Snoc = _Wrapped . _Snoc . bimapping _Unwrapped id+ {-# INLINE _Snoc #-}++-- | Compose two Located trails by adding a segment joining the endpoint+-- of the first to the starting point of the second. Note, if you have+-- two located trails such that the end of the first coincides with the+-- start of the second, this will still add a trivial zero-length segment+-- between them; in that case you are probably better off with something+-- like @mapLoc (<> unLoc t2) t1@.+instance+ (Real n, Floating n, Metric v) =>+ Semigroup (Located (Trail' Line v n))+ where+ a@(Loc aLoc aLine) <> b@(Loc _ bLine) =+ Loc aLoc (aLine <> lineFromOffsets [atStart b .-. atEnd a] <> bLine)++--------------------------------------------------+-- Extracting segments++-- | A newtype wrapper around trails which exists solely for its+-- 'Parametric', 'DomainBounds' and 'EndValues' instances. The idea+-- is that if @tr@ is a trail, you can write, /e.g./+--+-- @+-- getSegment tr `atParam` 0.6+-- @+--+-- or+--+-- @+-- atStart (getSegment tr)+-- @+--+-- to get the segment at parameter 0.6 or the first segment in the+-- trail, respectively.+--+-- The codomain for 'GetSegment', /i.e./ the result you get from+-- calling 'atParam', 'atStart', or 'atEnd', is+-- 'GetSegmentCodomain', which is a newtype wrapper around @Maybe+-- (v, Segment Closed v, AnIso' n n)@. @Nothing@ results if the+-- trail is empty; otherwise, you get:+--+-- * the offset from the start of the trail to the beginning of the+-- segment,+--+-- * the segment itself, and+--+-- * a reparameterization isomorphism: in the forward direction, it+-- translates from parameters on the whole trail to a parameters+-- on the segment. Note that for technical reasons you have to+-- call 'cloneIso' on the @AnIso'@ value to get a real isomorphism+-- you can use.+newtype GetSegment t = GetSegment t++newtype GetSegmentCodomain v n+ = GetSegmentCodomain+ ( Maybe+ ( v n -- offset from trail start to segment start+ , Segment Closed v n -- the segment+ , AnIso' n n -- reparameterization, trail <-> segment+ )+ )++-- | Create a 'GetSegment' wrapper around a trail, after which you can+-- call 'atParam', 'atStart', or 'atEnd' to extract a segment.+getSegment :: t -> GetSegment t+getSegment = GetSegment++type instance V (GetSegment t) = V t+type instance N (GetSegment t) = N t++type instance Codomain (GetSegment t) = GetSegmentCodomain (V t)++-- | Parameters less than 0 yield the first segment; parameters+-- greater than 1 yield the last. A parameter exactly at the+-- junction of two segments yields the second segment (/i.e./ the+-- one with higher parameter values).+instance (Metric v, OrderedField n) => Parametric (GetSegment (Trail' Line v n)) where+ atParam (GetSegment (Line (SegTree ft))) p+ | p <= 0 = case FT.viewl ft of+ EmptyL -> GetSegmentCodomain Nothing+ seg FT.:< _ -> GetSegmentCodomain $ Just (zero, seg, reparam 0)+ | p >= 1 = case FT.viewr ft of+ EmptyR -> GetSegmentCodomain Nothing+ ft' FT.:> seg -> GetSegmentCodomain $ Just (offset ft', seg, reparam (n - 1))+ | otherwise =+ let (before, after) = FT.split ((p * n <) . numSegs) ft+ in case FT.viewl after of+ EmptyL -> GetSegmentCodomain Nothing+ seg FT.:< _ -> GetSegmentCodomain $ Just (offset before, seg, reparam (numSegs before))+ where+ n = numSegs ft+ reparam k =+ iso+ (subtract k . (* n))+ ((/ n) . (+ k))++-- | The parameterization for loops wraps around, /i.e./ parameters+-- are first reduced \"mod 1\".+instance (Metric v, OrderedField n, Real n) => Parametric (GetSegment (Trail' Loop v n)) where+ atParam (GetSegment l) p = atParam (GetSegment (cutLoop l)) (mod1 p)++instance+ (Metric v, OrderedField n, Real n) =>+ Parametric (GetSegment (Trail v n))+ where+ atParam (GetSegment t) p =+ withTrail+ ((`atParam` p) . GetSegment)+ ((`atParam` p) . GetSegment)+ t++instance DomainBounds t => DomainBounds (GetSegment t) where+ domainLower (GetSegment t) = domainLower t+ domainUpper (GetSegment t) = domainUpper t++instance+ (Metric v, OrderedField n) =>+ EndValues (GetSegment (Trail' Line v n))+ where+ atStart (GetSegment (Line (SegTree ft))) =+ case FT.viewl ft of+ EmptyL -> GetSegmentCodomain Nothing+ seg FT.:< _ ->+ let n = numSegs ft+ in GetSegmentCodomain $ Just (zero, seg, iso (* n) (/ n))++ atEnd (GetSegment (Line (SegTree ft))) =+ case FT.viewr ft of+ EmptyR -> GetSegmentCodomain Nothing+ ft' FT.:> seg ->+ let n = numSegs ft+ in GetSegmentCodomain $+ Just+ ( offset ft'+ , seg+ , iso+ (subtract (n - 1) . (* n))+ ((/ n) . (+ (n - 1)))+ )++instance+ (Metric v, OrderedField n, Real n) =>+ EndValues (GetSegment (Trail' Loop v n))+ where+ atStart (GetSegment l) = atStart (GetSegment (cutLoop l))+ atEnd (GetSegment l) = atEnd (GetSegment (cutLoop l))++instance+ (Metric v, OrderedField n, Real n) =>+ EndValues (GetSegment (Trail v n))+ where+ atStart (GetSegment t) =+ withTrail+ (atStart . GetSegment)+ (atStart . GetSegment)+ t+ atEnd (GetSegment t) =+ withTrail+ (atEnd . GetSegment)+ (atEnd . GetSegment)+ t++--------------------------------------------------+-- 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 n where+ Trail :: Trail' l v n -> Trail v n++deriving instance Show (v n) => Show (Trail v n)++instance Eq (v n) => Eq (Trail v n) where+ t1 == t2 =+ withTrail+ (\ln1 -> withTrail (\ln2 -> ln1 == ln2) (const False) t2)+ (\lp1 -> withTrail (const False) (\lp2 -> lp1 == lp2) t2)+ t1++instance Ord (v n) => Ord (Trail v n) where+ compare t1 t2 =+ withTrail+ (\ln1 -> withTrail (compare ln1) (const LT) t2)+ (\lp1 -> withTrail (const GT) (compare lp1) 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 n, Metric v) => Semigroup (Trail v n) 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 (Metric v, OrderedField n) => Monoid (Trail v n) where+ mempty = wrapLine emptyLine+ mappend = (<>)++instance (Metric v, OrderedField n) => AsEmpty (Trail v n) where+ _Empty = nearly emptyTrail isTrailEmpty++type instance V (Trail v n) = v+type instance N (Trail v n) = n++type instance Codomain (Trail v n) = v++instance+ (HasLinearMap v, Metric v, OrderedField n) =>+ Transformable (Trail v n)+ where+ transform t = onTrail (transform t) (transform t)++instance (Metric v, OrderedField n) => Enveloped (Trail v n) where+ getEnvelope = withTrail getEnvelope getEnvelope++instance+ (Metric v, OrderedField n, Real n) =>+ Parametric (Trail v n)+ where+ atParam t p = withTrail (`atParam` p) (`atParam` p) t++instance Num n => DomainBounds (Trail v n)++instance (Metric v, OrderedField n, Real n) => EndValues (Trail v n)++-- | 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 (Metric v, OrderedField n, Real n) => Sectionable (Trail v n) where+ splitAtParam t p = withLine ((wrapLine *** wrapLine) . (`splitAtParam` p)) t++ section t p1 p2 = withLine (wrapLine . (\l -> section l p1 p2)) t++ reverseDomain = reverseTrail++instance+ (Metric v, OrderedField n, Real n) =>+ HasArcLength (Trail v n)+ where+ arcLengthBounded = withLine . arcLengthBounded+ arcLengthToParam eps tr al = withLine (\ln -> arcLengthToParam eps ln al) tr++-- lens instrances -----------------------------------------------------++-- | Prism onto a 'Line'.+_Line :: Prism' (Trail v n) (Trail' Line v n)+_Line = _Wrapped' . _Left++-- | Prism onto a 'Loop'.+_Loop :: Prism' (Trail v n) (Trail' Loop v n)+_Loop = _Wrapped' . _Right++-- | Prism onto a 'Located' 'Line'.+_LocLine :: Prism' (Located (Trail v n)) (Located (Trail' Line v n))+_LocLine = prism' (mapLoc Trail) $ located (preview _Line)++-- | Prism onto a 'Located' 'Loop'.+_LocLoop :: Prism' (Located (Trail v n)) (Located (Trail' Loop v n))+_LocLoop = prism' (mapLoc Trail) $ located (preview _Loop)++instance Rewrapped (Trail v n) (Trail v' n')+instance Wrapped (Trail v n) where+ type Unwrapped (Trail v n) = Either (Trail' Line v n) (Trail' Loop v n)+ _Wrapped' = iso getTrail (either Trail Trail)+ where+ getTrail :: Trail v n -> Either (Trail' Line v n) (Trail' Loop v n)+ getTrail (Trail t@(Line {})) = Left t+ getTrail (Trail t@(Loop {})) = Right t++--------------------------------------------------+-- 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 n -> r) -> (Trail' Loop v n -> r) -> Trail v n -> 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 n -> Trail' l1 v n) ->+ (Trail' Loop v n -> Trail' l2 v n) ->+ Trail v n ->+ Trail v n+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 ::+ (Metric v, OrderedField n) =>+ (Trail' Line v n -> r) -> Trail v n -> 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 ::+ (Metric v, OrderedField n) =>+ (Trail' Line v n -> Trail' Line v n) -> Trail v n -> Trail v n+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 n -> Trail v n+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 n -> Trail v n+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 n -> Trail v n+wrapLoop = wrapTrail++------------------------------------------------------------+-- Constructing trails -----------------------------------+------------------------------------------------------------++-- | The empty line, which is the identity for concatenation of lines.+emptyLine :: (Metric v, OrderedField n) => Trail' Line v n+emptyLine = Line mempty++-- | A wrapped variant of 'emptyLine'.+emptyTrail :: (Metric v, OrderedField n) => Trail v n+emptyTrail = wrapLine emptyLine++-- | Construct a line from a list of closed segments.+lineFromSegments ::+ (Metric v, OrderedField n) =>+ [Segment Closed v n] -> Trail' Line v n+lineFromSegments = Line . SegTree . FT.fromList++-- | Construct a loop from a list of closed segments and an open segment+-- that completes the loop.+loopFromSegments ::+ (Metric v, OrderedField n) =>+ [Segment Closed v n] -> Segment Open v n -> Trail' Loop v n+loopFromSegments segs = Loop (SegTree (FT.fromList segs))++-- | @trailFromSegments === 'wrapTrail' . 'lineFromSegments'@, for+-- conveniently constructing a @Trail@ instead of a @Trail'@.+trailFromSegments ::+ (Metric v, OrderedField n) =>+ [Segment Closed v n] -> Trail v n+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'.+--+-- <<diagrams/src_Diagrams_Trail_lineFromOffsetsEx.svg#diagram=lineFromOffsetsEx&width=300>>+--+-- > import Diagrams.Coordinates+-- > lineFromOffsetsEx = strokeLine $ lineFromOffsets [ 2 ^& 1, 2 ^& (-1), 2 ^& 0.5 ]+lineFromOffsets :: (Metric v, OrderedField n) => [v n] -> Trail' Line v n+lineFromOffsets = lineFromSegments . map straight++-- | @trailFromOffsets === 'wrapTrail' . 'lineFromOffsets'@, for+-- conveniently constructing a @Trail@ instead of a @Trail' Line@.+trailFromOffsets :: (Metric v, OrderedField n) => [v n] -> Trail v n+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)@.+--+-- <<diagrams/src_Diagrams_Trail_lineFromVerticesEx.svg#diagram=lineFromVerticesEx&width=300>>+--+-- > import Diagrams.Coordinates+-- > lineFromVerticesEx = pad 1.1 . centerXY . strokeLine+-- > $ lineFromVertices [origin, 0 ^& 1, 1 ^& 2, 5 ^& 1]+lineFromVertices ::+ (Metric v, OrderedField n) =>+ [Point v n] -> Trail' Line v n+lineFromVertices [] = emptyLine+lineFromVertices [_] = emptyLine+lineFromVertices ps = lineFromSegments . map straight $ zipWith (.-.) (drop 1 ps) ps++-- | @trailFromVertices === 'wrapTrail' . 'lineFromVertices'@, for+-- conveniently constructing a @Trail@ instead of a @Trail' Line@.+trailFromVertices ::+ (Metric v, OrderedField n) =>+ [Point v n] -> Trail v n+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.+--+-- <<diagrams/src_Diagrams_Trail_glueLineEx.svg#diagram=glueLineEx&width=500>>+--+-- > glueLineEx = pad 1.1 . hsep 1+-- > $ [almostClosed # strokeLine, almostClosed # glueLine # strokeLoop]+-- >+-- > almostClosed :: Trail' Line V2 Double+-- > almostClosed = fromOffsets $ map r2 [(2, -1), (-3, -0.5), (-2, 1), (1, 0.5)]+--+-- @glueLine@ is left inverse to 'cutLoop', that is,+--+-- @+-- glueLine . cutLoop === id+-- @+glueLine :: (Metric v, OrderedField n) => Trail' Line v n -> Trail' Loop v n+glueLine (Line (SegTree t)) =+ case FT.viewr t of+ FT.EmptyR -> Loop mempty (Linear OffsetOpen)+ t' FT.:> Linear _ -> Loop (SegTree t') (Linear OffsetOpen)+ t' FT.:> 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 :: (Metric v, OrderedField n) => Trail v n -> Trail v n+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+-- @+--+-- <<diagrams/src_Diagrams_Trail_closeLineEx.svg#diagram=closeLineEx&width=500>>+--+-- > closeLineEx = pad 1.1 . centerXY . hcat' (with & sep .~ 1)+-- > $ [almostClosed # strokeLine, almostClosed # closeLine # strokeLoop]+closeLine :: Trail' Line v n -> Trail' Loop v n+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 n -> Trail v n+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 n.+ (Metric v, OrderedField n) =>+ Trail' Loop v n -> Trail' Line v n+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 n+ offV = negated . trailMeasure zero (op TotalOffset . view 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 ::+ (Metric v, OrderedField n) =>+ Trail v n -> Trail v n+cutTrail = onTrail id cutLoop++------------------------------------------------------------+-- Eliminating trails ------------------------------------+------------------------------------------------------------++-- | Test whether a line is empty.+isLineEmpty :: (Metric v, OrderedField n) => Trail' Line v n -> Bool+isLineEmpty (Line (SegTree t)) = FT.null t++-- | Test whether a trail is empty. Note that loops are never empty.+isTrailEmpty :: (Metric v, OrderedField n) => Trail v n -> Bool+isTrailEmpty = withTrail isLineEmpty (const False)++-- | Determine whether a trail is a line.+isLine :: Trail v n -> Bool+isLine = not . isLoop++-- | Determine whether a trail is a loop.+isLoop :: Trail v n -> Bool+isLoop = withTrail (const False) (const True)++-- | Extract the segments comprising a line.+lineSegments :: Trail' Line v n -> [Segment Closed v n]+lineSegments (Line (SegTree t)) = F.toList t++-- | Modify a line by applying a function to its list of segments.+onLineSegments ::+ (Metric v, OrderedField n) =>+ ([Segment Closed v n] -> [Segment Closed v n]) ->+ Trail' Line v n ->+ Trail' Line v n+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 n -> ([Segment Closed v n], Segment Open v n)+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 ::+ (Metric v, OrderedField n) =>+ Trail v n -> [Segment Closed v n]+trailSegments = withLine lineSegments++-- | Extract the offsets of the segments of a trail.+trailOffsets :: (Metric v, OrderedField n) => Trail v n -> [v n]+trailOffsets = withLine lineOffsets++-- | Compute the offset from the start of a trail to the end. Satisfies+--+-- @+-- trailOffset === sumV . trailOffsets+-- @+--+-- but is more efficient.+--+-- <<diagrams/src_Diagrams_Trail_trailOffsetEx.svg#diagram=trailOffsetEx&width=300>>+--+-- > trailOffsetEx = (strokeLine almostClosed <> showOffset) # centerXY # pad 1.1+-- > where showOffset = fromOffsets [trailOffset (wrapLine almostClosed)]+-- > # strokeP # lc red+trailOffset :: (Metric v, OrderedField n) => Trail v n -> v n+trailOffset = withLine lineOffset++-- | Extract the offsets of the segments of a line.+lineOffsets :: Trail' Line v n -> [v n]+lineOffsets = map segOffset . lineSegments++-- | Extract the offsets of the segments of a loop.+loopOffsets :: (Metric v, OrderedField n) => Trail' Loop v n -> [v n]+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 :: (Metric v, OrderedField n) => Trail' Line v n -> v n+lineOffset (Line t) = trailMeasure zero (op TotalOffset . view oeOffset) t++-- | Extract the points of a concretely located trail, /i.e./ the points+-- where one segment ends and the next begins. Note that for loops,+-- the starting point 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 point at the start+-- and end, /e.g./ with @trailPoints . mapLoc cutTrail@.+--+-- Note that it does not make sense to ask for the points of a+-- 'Trail' by itself; if you want the points of a trail+-- with the first point at, say, the origin, you can use+-- @trailPoints . (\`at\` origin)@.+--+-- This function allows you "observe" the fact that trails are+-- implemented as lists of segments, which may be problematic if we+-- want to think of trails as parametric vector functions. This also+-- means that the behavior of this function may not be stable under+-- future changes to the implementation of trails. For an+-- unproblematic version which only yields vertices at which there+-- is a sharp corner, excluding points where the trail is+-- differentiable, see 'trailVertices'.+--+-- This function is not re-exported from "Diagrams.Prelude"; to use+-- it, import "Diagrams.Trail".+trailPoints ::+ (Metric v, OrderedField n) =>+ Located (Trail v n) -> [Point v n]+trailPoints (viewLoc -> (p, t)) =+ withTrail (linePoints . (`at` p)) (loopPoints . (`at` p)) t++-- | Extract the segment join points of a concretely located line. See+-- 'trailPoints' for more information.+--+-- This function allows you "observe" the fact that lines are+-- implemented as lists of segments, which may be problematic if we+-- want to think of lines as parametric vector functions. This also+-- means that the behavior of this function may not be stable under+-- future changes to the implementation of trails. For an+-- unproblematic version which only yields vertices at which there+-- is a sharp corner, excluding points where the trail is+-- differentiable, see 'lineVertices'.+--+-- This function is not re-exported from "Diagrams.Prelude"; to use+-- it, import "Diagrams.Trail".+linePoints ::+ (Metric v, OrderedField n) =>+ Located (Trail' Line v n) -> [Point v n]+linePoints (viewLoc -> (p, t)) =+ segmentPoints p . lineSegments $ t++-- | Extract the segment join points of a concretely located loop. Note that the+-- initial vertex is not repeated at the end. See 'trailPoints' for+-- more information.+--+-- This function allows you "observe" the fact that lines are+-- implemented as lists of segments, which may be problematic if we+-- want to think of lines as parametric vector functions. This also+-- means that the behavior of this function may not be stable under+-- future changes to the implementation of trails. For an+-- unproblematic version which only yields vertices at which there+-- is a sharp corner, excluding points where the trail is+-- differentiable, see 'lineVertices'.+--+-- This function is not re-exported from "Diagrams.Prelude"; to use+-- it, import "Diagrams.Trail".+loopPoints ::+ (Metric v, OrderedField n) =>+ Located (Trail' Loop v n) -> [Point v n]+loopPoints (viewLoc -> (p, t)) =+ segmentPoints p . fst . loopSegments $ t++segmentPoints :: (Additive v, Num n) => Point v n -> [Segment Closed v n] -> [Point v n]+segmentPoints p = scanl (.+^) p . map segOffset++tolerance :: OrderedField a => a+tolerance = 10e-16++-- | Extract the vertices of a concretely located trail. Here a /vertex/+-- is defined as a non-differentiable point on the trail, /i.e./ a+-- sharp corner. (Vertices are thus a subset of the places where+-- segments join; if you want all joins between segments, see+-- 'trailPoints'.) The tolerance determines how close the tangents+-- of two segments must be at their endpoints to consider the+-- transition point to be differentiable.+--+-- 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@.+--+-- 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' ::+ (Metric v, OrderedField n) =>+ n -> Located (Trail v n) -> [Point v n]+trailVertices' toler (viewLoc -> (p, t)) =+ withTrail (lineVertices' toler . (`at` p)) (loopVertices' toler . (`at` p)) t++-- | Like 'trailVertices'', with a default tolerance.+trailVertices ::+ (Metric v, OrderedField n) =>+ Located (Trail v n) -> [Point v n]+trailVertices = trailVertices' tolerance++-- | Extract the vertices of a concretely located line. See+-- 'trailVertices' for more information.+lineVertices' ::+ (Metric v, OrderedField n) =>+ n -> Located (Trail' Line v n) -> [Point v n]+lineVertices' toler (viewLoc -> (p, t)) =+ segmentVertices' toler p . lineSegments $ t++-- | Like 'lineVertices'', with a default tolerance.+lineVertices ::+ (Metric v, OrderedField n) =>+ Located (Trail' Line v n) -> [Point v n]+lineVertices = lineVertices' tolerance++-- | 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' ::+ (Metric v, OrderedField n) =>+ n -> Located (Trail' Loop v n) -> [Point v n]+loopVertices' toler (viewLoc -> (p, t)) = case NE.nonEmpty . lineSegments . cutLoop $ t of+ Nothing -> []+ Just segs+ | NE.length segs > 1 -> if far > toler then init ps else init . drop 1 $ ps+ | otherwise -> ps+ where+ far =+ quadrance+ ( (signorm . tangentAtStart . NE.head $ segs)+ ^-^ (signorm . tangentAtEnd . NE.last $ segs)+ )+ ps = segmentVertices' toler p (NE.toList segs)++-- | Same as 'loopVertices'', with a default tolerance.+loopVertices ::+ (Metric v, OrderedField n) =>+ Located (Trail' Loop v n) -> [Point v n]+loopVertices = loopVertices' tolerance++-- | The vertices of a list of segments laid end to end.+-- The start and end points are always included in the list of+-- vertices. The other points connecting segments are included if+-- the slope at the end of a segment is not equal to the slope at+-- the beginning of the next. The 'toler' parameter is used to+-- control how close the slopes need to be in order to declare them+-- equal.+segmentVertices' ::+ (Metric v, OrderedField n) =>+ n -> Point v n -> [Segment Closed v n] -> [Point v n]+segmentVertices' toler p ts =+ case ps of+ (x : _ : _) -> x : select (drop 1 ps) ds ++ [last ps]+ _ -> ps+ where+ ds = zipWith far tans (drop 1 tans)+ tans =+ [ ( signorm . tangentAtStart $ s+ , signorm . tangentAtEnd $ s+ )+ | s <- ts+ ]+ ps = scanl (.+^) p . map segOffset $ ts+ far p2 q2 = quadrance (snd p2 ^-^ fst q2) > toler++select :: [a] -> [Bool] -> [a]+select xs bs = map fst $ filter snd (zip xs bs)++-- | Convert a concretely located trail into a list of fixed segments.+-- 'unfixTrail' is almost its left inverse.+fixTrail ::+ (Metric v, OrderedField n) =>+ Located (Trail v n) -> [FixedSegment v n]+fixTrail t = map mkFixedSeg (trailLocSegments t)++-- | Convert a list of fixed segments into a located trail. Note that+-- this may lose information: it throws away the locations of all+-- but the first @FixedSegment@. This does not matter precisely+-- when each @FixedSegment@ begins where the previous one ends.+--+-- This is almost left inverse to 'fixTrail', that is, @unfixTrail+-- . fixTrail == id@, except for the fact that @unfixTrail@ will+-- never yield a @Loop@. In the case of a loop, we instead have+-- @glueTrail . unfixTrail . fixTrail == id@. On the other hand, it+-- is not the case that @fixTrail . unfixTrail == id@ since+-- @unfixTrail@ may lose information.+unfixTrail ::+ (Metric v, Ord n, Floating n) =>+ [FixedSegment v n] -> Located (Trail v n)+unfixTrail = mapLoc trailFromSegments . takeLoc . map fromFixedSeg+ where+ takeLoc [] = [] `at` origin+ takeLoc xs@(x : _) = map unLoc xs `at` loc x++-- | Convert a concretely located trail into a list of located segments.+trailLocSegments ::+ (Metric v, OrderedField n) =>+ Located (Trail v n) -> [Located (Segment Closed v n)]+trailLocSegments t = zipWith at (trailSegments (unLoc t)) (trailPoints 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 :: (Metric v, OrderedField n) => Trail v n -> Trail v n+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 ::+ (Metric v, OrderedField n) =>+ Located (Trail v n) -> Located (Trail v n)+reverseLocTrail (viewLoc -> (p, t)) = reverseTrail t `at` (p .+^ trailOffset t)++-- | Reverse a line. See 'reverseTrail'.+reverseLine ::+ (Metric v, OrderedField n) =>+ Trail' Line v n -> Trail' Line v n+reverseLine = onLineSegments (reverse . map reverseSegment)++-- | Reverse a concretely located line. See 'reverseLocTrail'.+reverseLocLine ::+ (Metric v, OrderedField n) =>+ Located (Trail' Line v n) -> Located (Trail' Line v n)+reverseLocLine (viewLoc -> (p, l)) = reverseLine l `at` (p .+^ lineOffset l)++-- | Reverse a loop. See 'reverseTrail'.+reverseLoop ::+ (Metric v, OrderedField n) =>+ Trail' Loop v n -> Trail' Loop v n+reverseLoop = glueLine . reverseLine . cutLoop++-- | Reverse a concretely located loop. See 'reverseLocTrail'. Note+-- that this is guaranteed to preserve the location.+reverseLocLoop ::+ (Metric v, OrderedField n) =>+ Located (Trail' Loop v n) -> Located (Trail' Loop v n)+reverseLocLoop = mapLoc reverseLoop++-- | Same as 'reverseLine' or 'reverseLoop'.+instance (Metric v, OrderedField n) => Reversing (Trail' l v n) where+ reversing t@(Line _) = onLineSegments (reverse . map reversing) t+ reversing t@(Loop _ _) = glueLine . reversing . cutLoop $ t++-- | Same as 'reverseTrail'.+instance (Metric v, OrderedField n) => Reversing (Trail v n) where+ reversing (Trail t) = Trail (reversing t)++-- | Same as 'reverseLocLine' or 'reverseLocLoop'.+instance (Metric v, OrderedField n) => Reversing (Located (Trail' l v n)) where+ reversing l@(Loc _ Line {}) = reverseLocLine l+ reversing l@(Loc _ Loop {}) = reverseLocLoop l++-- | Same as 'reverseLocTrail'.+instance (Metric v, OrderedField n) => Reversing (Located (Trail v n)) where+ reversing = reverseLocTrail++------------------------------------------------------------+-- Serialize instances+------------------------------------------------------------++instance (Serialize (v n), OrderedField n, Metric v) => Serialize (Trail v n) where+ {-# INLINE get #-}+ get = do+ isLine <- Serialize.get+ case isLine of+ True -> do+ segTree <- Serialize.get+ return (Trail (Line segTree))+ False -> do+ segTree <- Serialize.get+ segment <- Serialize.get+ return (Trail (Loop segTree segment))++ {-# INLINE put #-}+ put (Trail (Line segTree)) = do+ Serialize.put True+ Serialize.put segTree put (Trail (Loop segTree segment)) = do Serialize.put False Serialize.put segTree
src/Diagrams/Transform/ScaleInv.hs view
@@ -74,7 +74,6 @@ , _scaleInvDir :: Vn t , _scaleInvLoc :: Point (V t) (N t) }- deriving Typeable deriving instance (Show t, Show (Vn t)) => Show (ScaleInv t)
src/Diagrams/TwoD/Arrow.hs view
@@ -1,16 +1,15 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ -- | -- Module : Diagrams.TwoD.Arrow -- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE)@@ -20,161 +19,165 @@ -- Drawing arrows in two dimensions. For a tutorial on drawing arrows -- using this module, see the diagrams website: -- <https://diagrams.github.io/doc/arrow.html>.------------------------------------------------------------------------------------module Diagrams.TwoD.Arrow- ( -- * Examples- -- ** Example 1--- | <<diagrams/src_Diagrams_TwoD_Arrow_example1.svg#diagram=example1&width=500>>------ > -- Connecting two diagrams at their origins.--- >--- > sq = square 2 # showOrigin # lc darkgray # lw ultraThick--- > ds = (sq # named "left") ||| strutX 3 ||| (sq # named "right")--- >--- > shaft = cubicSpline False ( map p2 [(0, 0), (1, 0), (1, 0.2), (2, 0.2)])--- >--- > example1 = ds # connect' (with & arrowHead .~ dart & arrowTail .~ quill--- > & arrowShaft .~ shaft--- > & headLength .~ huge & tailLength .~ veryLarge)--- > "left" "right" # pad 1.1-- -- ** Example 2---- | <<diagrams/src_Diagrams_TwoD_Arrow_example2.svg#diagram=example2&width=500>>------ > -- Comparing connect, connectPerim, and arrowAt.--- >--- > oct = octagon 1 # lc darkgray # lw ultraThick # showOrigin--- > dias = oct # named "first" ||| strut 3 ||| oct # named "second"--- >--- > -- Connect two diagrams and two points on their trails.--- > ex12 = dias # connect' (with & lengths .~ veryLarge) "first" "second"--- > # connectPerim' (with & lengths .~ veryLarge)--- > "first" "second" (15/16 @@ turn) (9/16 @@ turn)--- >--- > -- Place an arrow at (0,0) the size and direction of (0,1).--- > ex3 = arrowAt origin unit_Y--- >--- > example2 = (ex12 <> ex3) # centerXY # pad 1.1-- -- * Creating arrows- arrowV- , arrowV'- , arrowAt- , arrowAt'- , arrowBetween- , arrowBetween'- , connect- , connect'- , connectPerim- , connectPerim'- , connectOutside- , connectOutside'+module Diagrams.TwoD.Arrow (+ -- * Examples - , arrow- , arrow'+ -- ** Example 1 - , arrowFromLocatedTrail- , arrowFromLocatedTrail'+ -- | <<diagrams/src_Diagrams_TwoD_Arrow_example1.svg#diagram=example1&width=500>>+ --+ -- > -- Connecting two diagrams at their origins.+ -- >+ -- > sq = square 2 # showOrigin # lc darkgray # lw ultraThick+ -- > ds = (sq # named "left") ||| strutX 3 ||| (sq # named "right")+ -- >+ -- > shaft = cubicSpline False ( map p2 [(0, 0), (1, 0), (1, 0.2), (2, 0.2)])+ -- >+ -- > example1 = ds # connect' (with & arrowHead .~ dart & arrowTail .~ quill+ -- > & arrowShaft .~ shaft+ -- > & headLength .~ huge & tailLength .~ veryLarge)+ -- > "left" "right" # pad 1.1 - -- * Options- , ArrowOpts(..)+ -- ** Example 2 - , arrowHead- , arrowTail- , arrowShaft- , headGap- , tailGap- , gaps, gap- , headTexture- , headStyle- , headLength- , tailTexture- , tailStyle- , tailLength- , lengths- , shaftTexture- , shaftStyle- , straightShaft+ -- | <<diagrams/src_Diagrams_TwoD_Arrow_example2.svg#diagram=example2&width=500>>+ --+ -- > -- Comparing connect, connectPerim, and arrowAt.+ -- >+ -- > oct = octagon 1 # lc darkgray # lw ultraThick # showOrigin+ -- > dias = oct # named "first" ||| strut 3 ||| oct # named "second"+ -- >+ -- > -- Connect two diagrams and two points on their trails.+ -- > ex12 = dias # connect' (with & lengths .~ veryLarge) "first" "second"+ -- > # connectPerim' (with & lengths .~ veryLarge)+ -- > "first" "second" (15/16 @@ turn) (9/16 @@ turn)+ -- >+ -- > -- Place an arrow at (0,0) the size and direction of (0,1).+ -- > ex3 = arrowAt origin unit_Y+ -- >+ -- > example2 = (ex12 <> ex3) # centerXY # pad 1.1 - -- | See "Diagrams.TwoD.Arrowheads" for a list of standard- -- arrowheads and help creating your own.- , module Diagrams.TwoD.Arrowheads- ) where+ -- * Creating arrows+ arrowV,+ arrowV',+ arrowAt,+ arrowAt',+ arrowBetween,+ arrowBetween',+ connect,+ connect',+ connectPerim,+ connectPerim',+ connectOutside,+ connectOutside',+ arrow,+ arrow',+ arrowFromLocatedTrail,+ arrowFromLocatedTrail', -import Control.Lens (Lens', Traversal',- generateSignatures, lensRules,- makeLensesWith, view, (%~), (&),- (.~), (^.))-import Data.Default-import Data.Maybe (fromMaybe)-import Data.Monoid.Coproduct (untangle)-import Data.Semigroup-import Data.Typeable+ -- * Options+ ArrowOpts (..),+ arrowHead,+ arrowTail,+ arrowShaft,+ headGap,+ tailGap,+ gaps,+ gap,+ headTexture,+ headStyle,+ headLength,+ tailTexture,+ tailStyle,+ tailLength,+ lengths,+ shaftTexture,+ shaftStyle,+ straightShaft,+ -- | See "Diagrams.TwoD.Arrowheads" for a list of standard+ -- arrowheads and help creating your own.+ module Diagrams.TwoD.Arrowheads,+) where -import Data.Colour hiding (atop)-import Diagrams.Core-import Diagrams.Core.Style (unmeasureAttrs)-import Diagrams.Core.Types (QDiaLeaf (..), mkQD')+import Control.Lens (+ Lens',+ Traversal',+ both,+ generateSignatures,+ lensRules,+ makeLensesWith,+ over,+ view,+ (%~),+ (&),+ (.~),+ (^.),+ )+import Data.Default+import Data.Maybe (fromMaybe)+import Data.Monoid.Coproduct (untangle)+import Data.Semigroup+import Data.Typeable -import Diagrams.Angle-import Diagrams.Attributes-import Diagrams.Direction hiding (dir)-import Diagrams.Located (Located (..), unLoc)-import Diagrams.Parametric-import Diagrams.Path-import Diagrams.Solve.Polynomial (quadForm)-import Diagrams.Tangent (tangentAtEnd, tangentAtStart)-import Diagrams.Trail-import Diagrams.TwoD.Arrowheads-import Diagrams.TwoD.Attributes-import Diagrams.TwoD.Path (stroke, strokeT)-import Diagrams.TwoD.Transform (reflectY, translateX)-import Diagrams.TwoD.Types-import Diagrams.TwoD.Vector (unitX, unit_X)-import Diagrams.Util (( # ))+import Data.Colour hiding (atop, over)+import Diagrams.Core+import Diagrams.Core.Style (unmeasureAttrs)+import Diagrams.Core.Types (QDiaLeaf (..), mkQD') -import Linear.Affine-import Linear.Metric-import Linear.Vector+import Diagrams.Angle+import Diagrams.Attributes+import Diagrams.Direction hiding (dir)+import Diagrams.Located (Located (..), unLoc)+import Diagrams.Parametric+import Diagrams.Path+import Diagrams.Solve.Polynomial (quadForm)+import Diagrams.Tangent (tangentAtEnd, tangentAtStart)+import Diagrams.Trail+import Diagrams.TwoD.Arrowheads+import Diagrams.TwoD.Attributes+import Diagrams.TwoD.Path (stroke, strokeT)+import Diagrams.TwoD.Transform (reflectY, translateX)+import Diagrams.TwoD.Types+import Diagrams.TwoD.Vector (unitX, unit_X)+import Diagrams.Util ((#)) +import Linear.Affine+import Linear.Metric+import Linear.Vector data ArrowOpts n = ArrowOpts- { _arrowHead :: ArrowHT n- , _arrowTail :: ArrowHT n- , _arrowShaft :: Trail V2 n- , _headGap :: Measure n- , _tailGap :: Measure n- , _headStyle :: Style V2 n- , _headLength :: Measure n- , _tailStyle :: Style V2 n- , _tailLength :: Measure n- , _shaftStyle :: Style V2 n- }+ { _arrowHead :: ArrowHT n+ , _arrowTail :: ArrowHT n+ , _arrowShaft :: Trail V2 n+ , _headGap :: Measure n+ , _tailGap :: Measure n+ , _headStyle :: Style V2 n+ , _headLength :: Measure n+ , _tailStyle :: Style V2 n+ , _tailLength :: Measure n+ , _shaftStyle :: Style V2 n+ } -- | Straight line arrow shaft. straightShaft :: OrderedField n => Trail V2 n straightShaft = trailFromOffsets [unitX] instance TypeableFloat n => Default (ArrowOpts n) where- def = ArrowOpts- { _arrowHead = dart- , _arrowTail = noTail- , _arrowShaft = straightShaft- , _headGap = none- , _tailGap = none-- -- See note [Default arrow style attributes]- , _headStyle = mempty- , _headLength = normal- , _tailStyle = mempty- , _tailLength = normal- , _shaftStyle = mempty- }+ def =+ ArrowOpts+ { _arrowHead = dart+ , _arrowTail = noTail+ , _arrowShaft = straightShaft+ , _headGap = none+ , _tailGap = none+ , -- See note [Default arrow style attributes]+ _headStyle = mempty+ , _headLength = normal+ , _tailStyle = mempty+ , _tailLength = normal+ , _shaftStyle = mempty+ } makeLensesWith (lensRules & generateSignatures .~ False) ''ArrowOpts @@ -195,9 +198,10 @@ -- | Set both the @headGap@ and @tailGap@ simultaneously. gaps :: Traversal' (ArrowOpts n) (Measure n)-gaps f opts = (\h t -> opts & headGap .~ h & tailGap .~ t)- <$> f (opts ^. headGap)- <*> f (opts ^. tailGap)+gaps f opts =+ (\h t -> opts & headGap .~ h & tailGap .~ t)+ <$> f (opts ^. headGap)+ <*> f (opts ^. tailGap) -- | Same as gaps, provided for backward compatiiblity. gap :: Traversal' (ArrowOpts n) (Measure n)@@ -252,23 +256,23 @@ -- The semigroup stucture of the lw attribute will insure that the default -- is only used if it has not been set in @opts@. shaftSty :: ArrowOpts n -> Style V2 n-shaftSty opts = opts^.shaftStyle+shaftSty opts = opts ^. shaftStyle -- Set the default head style. See `shaftSty`. headSty :: TypeableFloat n => ArrowOpts n -> Style V2 n-headSty opts = fc black (opts^.headStyle)+headSty opts = fc black (opts ^. headStyle) -- Set the default tail style. See `shaftSty`. tailSty :: TypeableFloat n => ArrowOpts n -> Style V2 n-tailSty opts = fc black (opts^.tailStyle)+tailSty opts = fc black (opts ^. tailStyle) -- | Calculate the length of the portion of the horizontal line that passes -- through the origin and is inside of p. xWidth :: Floating n => (Traced t, V t ~ V2, N t ~ n) => t -> n xWidth p = a + b- where- a = fromMaybe 0 (norm <$> traceV origin unitX p)- b = fromMaybe 0 (norm <$> traceV origin unit_X p)+ where+ a = fromMaybe 0 (norm <$> traceV origin unitX p)+ b = fromMaybe 0 (norm <$> traceV origin unit_X p) -- | Get the line color from the shaft to use as the fill color for the joint. -- And set the opacity of the shaft to the current opacity.@@ -276,12 +280,11 @@ colorJoint sStyle = let c = fmap getLineTexture . getAttr $ sStyle o = fmap getOpacity . getAttr $ sStyle- in- case (c, o) of- (Nothing, Nothing) -> fillColor black mempty- (Just t, Nothing) -> fillTexture t mempty- (Nothing, Just o') -> opacity o' . fillColor black $ mempty- (Just t, Just o') -> opacity o' . fillTexture t $ mempty+ in case (c, o) of+ (Nothing, Nothing) -> fillColor black mempty+ (Just t, Nothing) -> fillTexture t mempty+ (Nothing, Just o') -> opacity o' . fillColor black $ mempty+ (Just t, Just o') -> opacity o' . fillTexture t $ mempty -- | Get line width from a style. widthOfJoint :: forall n. TypeableFloat n => Style V2 n -> n -> n -> n@@ -293,31 +296,43 @@ -- | Combine the head and its joint into a single scale invariant diagram -- and move the origin to the attachment point. Return the diagram -- and its width.-mkHead :: (TypeableFloat n, Renderable (Path V2 n) b) =>- n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n)+mkHead ::+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) mkHead = mkHT unit_X arrowHead headSty -mkTail :: (TypeableFloat n, Renderable (Path V2 n) b) =>- n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n)+mkTail ::+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) mkTail = mkHT unitX arrowTail tailSty -mkHT- :: (TypeableFloat n, Renderable (Path V2 n) b)- => V2 n -> Lens' (ArrowOpts n) (ArrowHT n) -> (ArrowOpts n -> Style V2 n)- -> n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n)-mkHT xDir htProj styProj sz opts gToO nToO reflect- = ( (j <> ht)- # (if reflect then reflectY else id)- # moveOriginBy (jWidth *^ xDir) # lwO 0- , htWidth + jWidth- )- where- (ht', j') = (opts^.htProj) sz- (widthOfJoint (shaftSty opts) gToO nToO)- htWidth = xWidth ht'- jWidth = xWidth j'- ht = stroke ht' # applyStyle (styProj opts)- j = stroke j' # applyStyle (colorJoint (opts^.shaftStyle))+mkHT ::+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ V2 n ->+ Lens' (ArrowOpts n) (ArrowHT n) ->+ (ArrowOpts n -> Style V2 n) ->+ n ->+ ArrowOpts n ->+ n ->+ n ->+ Bool ->+ (QDiagram b V2 n Any, n)+mkHT xDir htProj styProj sz opts gToO nToO reflect =+ ( (j <> ht)+ # (if reflect then reflectY else id)+ # moveOriginBy (jWidth *^ xDir)+ # lwO 0+ , htWidth + jWidth+ )+ where+ (ht', j') =+ (opts ^. htProj)+ sz+ (widthOfJoint (shaftSty opts) gToO nToO)+ htWidth = xWidth ht'+ jWidth = xWidth j'+ ht = stroke ht' # applyStyle (styProj opts)+ j = stroke j' # applyStyle (colorJoint (opts ^. shaftStyle)) -- | @spine tr tw hw sz@ makes a trail with the same angles and offset -- as an arrow with tail width @t@w, head width @hw@ and shaft @tr@,@@ -325,18 +340,17 @@ -- calculating the offset of an arrow. spine :: TypeableFloat n => Trail V2 n -> n -> n -> n -> Trail V2 n spine tr tw hw sz = tS <> tr # scale sz <> hS- where- tSpine = trailFromOffsets [signorm . tangentAtStart $ tr] # scale tw- hSpine = trailFromOffsets [signorm . tangentAtEnd $ tr] # scale hw- hS = if hw > 0 then hSpine else mempty- tS = if tw > 0 then tSpine else mempty+ where+ tSpine = trailFromOffsets [signorm . tangentAtStart $ tr] # scale tw+ hSpine = trailFromOffsets [signorm . tangentAtEnd $ tr] # scale hw+ hS = if hw > 0 then hSpine else mempty+ tS = if tw > 0 then tSpine else mempty -- | @scaleFactor tr tw hw t@ calculates the amount required to scale -- a shaft trail @tr@ so that an arrow with head width @hw@ and tail -- width @tw@ has offset @t@. scaleFactor :: TypeableFloat n => Trail V2 n -> n -> n -> n -> n-scaleFactor tr tw hw t-+scaleFactor tr tw hw t = -- Let tv be a vector representing the tail width, i.e. a vector -- of length tw tangent to the trail's start; similarly for hv. -- Let v be the vector offset of the trail.@@ -348,30 +362,30 @@ -- We can solve by squaring both sides and expanding the LHS as a -- dot product, resulting in a quadratic in k. - = case quadForm- (quadrance v)- (2* (v `dot` (tv ^+^ hv)))- (quadrance (tv ^+^ hv) - t*t)- of- [] -> 1 -- no scale works, just return 1- [s] -> s -- single solution- ss -> maximum ss- -- we will usually get both a positive and a negative solution;- -- return the maximum (i.e. positive) solution- where- tv = tw *^ (tangentAtStart tr # signorm)- hv = hw *^ (tangentAtEnd tr # signorm)- v = trailOffset tr+ case quadForm+ (quadrance v)+ (2 * (v `dot` (tv ^+^ hv)))+ (quadrance (tv ^+^ hv) - t * t) of+ [] -> 1 -- no scale works, just return 1+ [s] -> s -- single solution+ ss -> maximum ss+ where+ -- we will usually get both a positive and a negative solution;+ -- return the maximum (i.e. positive) solution + tv = tw *^ (tangentAtStart tr # signorm)+ hv = hw *^ (tangentAtEnd tr # signorm)+ v = trailOffset tr+ -- Calculate the approximate envelope of a horizontal arrow -- as if the arrow were made only of a shaft. arrowEnv :: TypeableFloat n => ArrowOpts n -> n -> Envelope V2 n arrowEnv opts len = getEnvelope horizShaft- where- horizShaft = shaft # rotate (negated (v ^. _theta)) # scale (len / m)- m = norm v- v = trailOffset shaft- shaft = opts ^. arrowShaft+ where+ horizShaft = shaft # rotate (negated (v ^. _theta)) # scale (len / m)+ m = norm v+ v = trailOffset shaft+ shaft = opts ^. arrowShaft -- | @arrow len@ creates an arrow of length @len@ with default -- parameters, starting at the origin and ending at the point@@ -384,92 +398,97 @@ -- @(len,0)@. In particular, it scales the given 'arrowShaft' so -- that the entire arrow has length @len@. arrow' :: (TypeableFloat n, Renderable (Path V2 n) b) => ArrowOpts n -> n -> QDiagram b V2 n Any-arrow' opts len = mkQD' (DelayedLeaf delayedArrow)-- -- Currently we approximate the envelope of an arrow by using the- -- envelope of its shaft (see 'arrowEnv'). The trace of an arrow is empty.- (arrowEnv opts len) mempty mempty mempty-- where-- -- Once we learn the global transformation context (da) and the two scale- -- factors, normal to output (n) and global to output (g), this arrow is- -- drawn in, we can apply it to the origin and (len,0) to find out- -- the actual final points between which this arrow should be- -- drawn. We need to know this to draw it correctly, since the- -- head and tail are scale invariant, and hence the precise points- -- between which we need to draw the shaft do not transform- -- uniformly as the transformation applied to the entire arrow.- -- See https://github.com/diagrams/diagrams-lib/issues/112.- delayedArrow da g n =- let (trans, globalSty) = maybe mempty untangle . fst $ da- in dArrow globalSty trans len g n-- -- Build an arrow and set its endpoints to the image under tr of origin and (len,0).- dArrow sty tr ln gToO nToO = (h' <> t' <> shaft)- # moveOriginBy (tWidth *^ (unit_X # rotate tAngle))- # rotate (((q .-. p)^._theta) ^-^ (dir^._theta))- # moveTo p- where+arrow' opts len =+ mkQD'+ (DelayedLeaf delayedArrow)+ -- Currently we approximate the envelope of an arrow by using the+ -- envelope of its shaft (see 'arrowEnv'). The trace of an arrow is empty.+ (arrowEnv opts len)+ mempty+ mempty+ mempty+ where+ -- Once we learn the global transformation context (da) and the two scale+ -- factors, normal to output (n) and global to output (g), this arrow is+ -- drawn in, we can apply it to the origin and (len,0) to find out+ -- the actual final points between which this arrow should be+ -- drawn. We need to know this to draw it correctly, since the+ -- head and tail are scale invariant, and hence the precise points+ -- between which we need to draw the shaft do not transform+ -- uniformly as the transformation applied to the entire arrow.+ -- See https://github.com/diagrams/diagrams-lib/issues/112.+ delayedArrow da g n =+ let (trans, globalSty) = maybe mempty untangle . fst $ da+ in dArrow globalSty trans len g n - p = origin # transform tr- q = origin # translateX ln # transform tr+ -- Build an arrow and set its endpoints to the image under tr of origin and (len,0).+ dArrow sty tr ln gToO nToO =+ (h' <> t' <> shaft)+ # moveOriginBy (tWidth *^ (unit_X # rotate tAngle))+ # rotate (((q .-. p) ^. _theta) ^-^ (dir ^. _theta))+ # moveTo p+ where+ p = origin # transform tr+ q = origin # translateX ln # transform tr - -- Use the existing line color for head, tail, and shaft by- -- default (can be overridden by explicitly setting headStyle,- -- tailStyle, or shaftStyle). Also use existing global line width- -- for shaft if not explicitly set in shaftStyle.- globalLC = getLineTexture <$> getAttr sty- opts' = opts- & headStyle %~ maybe id fillTexture globalLC- & tailStyle %~ maybe id fillTexture globalLC- & shaftStyle %~ applyStyle sty . transform tr+ -- Use the existing line color for head, tail, and shaft by+ -- default (can be overridden by explicitly setting headStyle,+ -- tailStyle, or shaftStyle). Also use existing global line width+ -- for shaft if not explicitly set in shaftStyle.+ globalLC = getLineTexture <$> getAttr sty+ opts' =+ opts+ & headStyle %~ maybe id fillTexture globalLC+ & tailStyle %~ maybe id fillTexture globalLC+ & shaftStyle %~ applyStyle sty . transform tr - -- The head size, tail size, head gap, and tail gap are obtained- -- from the style and converted to output units.- scaleFromMeasure = fromMeasured gToO nToO . scaleLocal (avgScale tr)- hSize = scaleFromMeasure $ opts ^. headLength- tSize = scaleFromMeasure $ opts ^. tailLength- hGap = scaleFromMeasure $ opts ^. headGap- tGap = scaleFromMeasure $ opts ^. tailGap+ -- The head size, tail size, head gap, and tail gap are obtained+ -- from the style and converted to output units.+ scaleFromMeasure = fromMeasured gToO nToO . scaleLocal (avgScale tr)+ hSize = scaleFromMeasure $ opts ^. headLength+ tSize = scaleFromMeasure $ opts ^. tailLength+ hGap = scaleFromMeasure $ opts ^. headGap+ tGap = scaleFromMeasure $ opts ^. tailGap - -- Make the head and tail and save their widths.- (h, hWidth') = mkHead hSize opts' gToO nToO (isReflection tr)- (t, tWidth') = mkTail tSize opts' gToO nToO (isReflection tr)+ -- Make the head and tail and save their widths.+ (h, hWidth') = mkHead hSize opts' gToO nToO (isReflection tr)+ (t, tWidth') = mkTail tSize opts' gToO nToO (isReflection tr) - rawShaftTrail = opts^.arrowShaft- shaftTrail- = rawShaftTrail- -- rotate it so it is pointing in the positive X direction- # rotate (negated . view _theta . trailOffset $ rawShaftTrail)- -- apply the context transformation -- in case it includes- -- things like flips and shears (the possibility of shears- -- is why we must rotate it to a neutral position first)- # transform tr+ rawShaftTrail = opts ^. arrowShaft+ shaftTrail =+ rawShaftTrail+ -- rotate it so it is pointing in the positive X direction+ # rotate (negated . view _theta . trailOffset $ rawShaftTrail)+ -- apply the context transformation -- in case it includes+ -- things like flips and shears (the possibility of shears+ -- is why we must rotate it to a neutral position first)+ # transform tr - -- Adjust the head width and tail width to take gaps into account- tWidth = tWidth' + tGap- hWidth = hWidth' + hGap+ -- Adjust the head width and tail width to take gaps into account+ tWidth = tWidth' + tGap+ hWidth = hWidth' + hGap - -- Calculate the angles that the head and tail should point.- tAngle = tangentAtStart shaftTrail ^. _theta- hAngle = tangentAtEnd shaftTrail ^. _theta+ -- Calculate the angles that the head and tail should point.+ tAngle = tangentAtStart shaftTrail ^. _theta+ hAngle = tangentAtEnd shaftTrail ^. _theta - -- Calculte the scaling factor to apply to the shaft shaftTrail so that the entire- -- arrow will be of length len. Then apply it to the shaft and make the- -- shaft into a Diagram with using its style.- sf = scaleFactor shaftTrail tWidth hWidth (norm (q .-. p))- shaftTrail' = shaftTrail # scale sf- shaft = strokeT shaftTrail' # applyStyle (shaftSty opts')+ -- Calculte the scaling factor to apply to the shaft shaftTrail so that the entire+ -- arrow will be of length len. Then apply it to the shaft and make the+ -- shaft into a Diagram with using its style.+ sf = scaleFactor shaftTrail tWidth hWidth (norm (q .-. p))+ shaftTrail' = shaftTrail # scale sf+ shaft = strokeT shaftTrail' # applyStyle (shaftSty opts') - -- Adjust the head and tail to point in the directions of the shaft ends.- h' = h # rotate hAngle- # moveTo (origin .+^ shaftTrail' `atParam` domainUpper shaftTrail')- t' = t # rotate tAngle+ -- Adjust the head and tail to point in the directions of the shaft ends.+ h' =+ h+ # rotate hAngle+ # moveTo (origin .+^ shaftTrail' `atParam` domainUpper shaftTrail')+ t' = t # rotate tAngle - -- Find out what direction the arrow is pointing so we can set it back- -- to point in the direction unitX when we are done.- dir = direction (trailOffset $ spine shaftTrail tWidth hWidth sf)+ -- Find out what direction the arrow is pointing so we can set it back+ -- to point in the direction unitX when we are done.+ dir = direction (trailOffset $ spine shaftTrail tWidth hWidth sf) -- | @arrowBetween s e@ creates an arrow pointing from @s@ to @e@ -- with default parameters.@@ -480,9 +499,9 @@ -- @e@ using the given options. In particular, it scales and -- rotates @arrowShaft@ to go between @s@ and @e@, taking head, -- tail, and gaps into account.-arrowBetween'- :: (TypeableFloat n, Renderable (Path V2 n) b) =>- ArrowOpts n -> Point V2 n -> Point V2 n -> QDiagram b V2 n Any+arrowBetween' ::+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ ArrowOpts n -> Point V2 n -> Point V2 n -> QDiagram b V2 n Any arrowBetween' opts s e = arrowAt' opts s (e .-. s) -- | Create an arrow starting at s with length and direction determined by@@ -490,14 +509,16 @@ arrowAt :: (TypeableFloat n, Renderable (Path V2 n) b) => Point V2 n -> V2 n -> QDiagram b V2 n Any arrowAt = arrowAt' def -arrowAt'- :: (TypeableFloat n, Renderable (Path V2 n) b) =>- ArrowOpts n -> Point V2 n -> V2 n -> QDiagram b V2 n Any-arrowAt' opts s v = arrow' opts len- # rotate dir # moveTo s- where- len = norm v- dir = v ^. _theta+arrowAt' ::+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ ArrowOpts n -> Point V2 n -> V2 n -> QDiagram b V2 n Any+arrowAt' opts s v =+ arrow' opts len+ # rotate dir+ # moveTo s+ where+ len = norm v+ dir = v ^. _theta -- | @arrowV v@ creates an arrow with the direction and norm of -- the vector @v@ (with its tail at the origin), using default@@ -507,82 +528,90 @@ -- | @arrowV' v@ creates an arrow with the direction and norm of -- the vector @v@ (with its tail at the origin).-arrowV'- :: (TypeableFloat n, Renderable (Path V2 n) b)- => ArrowOpts n -> V2 n -> QDiagram b V2 n Any+arrowV' ::+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ ArrowOpts n -> V2 n -> QDiagram b V2 n Any arrowV' opts = arrowAt' opts origin -- | Turn a located trail into a default arrow by putting an -- arrowhead at the end of the trail.-arrowFromLocatedTrail- :: (Renderable (Path V2 n) b, RealFloat n, Typeable n)- => Located (Trail V2 n) -> QDiagram b V2 n Any+arrowFromLocatedTrail ::+ (Renderable (Path V2 n) b, RealFloat n, Typeable n) =>+ Located (Trail V2 n) -> QDiagram b V2 n Any arrowFromLocatedTrail = arrowFromLocatedTrail' def -- | Turn a located trail into an arrow using the given options.-arrowFromLocatedTrail'- :: (Renderable (Path V2 n) b, RealFloat n, Typeable n)- => ArrowOpts n -> Located (Trail V2 n) -> QDiagram b V2 n Any+arrowFromLocatedTrail' ::+ (Renderable (Path V2 n) b, RealFloat n, Typeable n) =>+ ArrowOpts n -> Located (Trail V2 n) -> QDiagram b V2 n Any arrowFromLocatedTrail' opts trail = arrowBetween' opts' start end- where- opts' = opts & arrowShaft .~ unLoc trail- start = atStart trail- end = atEnd trail+ where+ opts' = opts & arrowShaft .~ unLoc trail+ start = atStart trail+ end = atEnd trail -- | Connect two diagrams with a straight arrow.-connect- :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2)- => n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any+connect ::+ (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) =>+ n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any connect = connect' def -- | Connect two diagrams with an arbitrary arrow.-connect'- :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2)- => ArrowOpts n -> n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any+connect' ::+ (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) =>+ ArrowOpts n -> n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any connect' opts n1 n2 = withName n1 $ \sub1 ->- withName n2 $ \sub2 ->- let [s,e] = map location [sub1, sub2]- in atop (arrowBetween' opts s e)+ withName n2 $ \sub2 ->+ let (s, e) = over both location (sub1, sub2)+ in atop (arrowBetween' opts s e) -- | Connect two diagrams at point on the perimeter of the diagrams, choosen -- by angle.-connectPerim- :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2)- => n1 -> n2 -> Angle n -> Angle n- -> QDiagram b V2 n Any -> QDiagram b V2 n Any+connectPerim ::+ (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) =>+ n1 ->+ n2 ->+ Angle n ->+ Angle n ->+ QDiagram b V2 n Any ->+ QDiagram b V2 n Any connectPerim = connectPerim' def -connectPerim'- :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2)- => ArrowOpts n -> n1 -> n2 -> Angle n -> Angle n- -> QDiagram b V2 n Any -> QDiagram b V2 n Any+connectPerim' ::+ (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) =>+ ArrowOpts n ->+ n1 ->+ n2 ->+ Angle n ->+ Angle n ->+ QDiagram b V2 n Any ->+ QDiagram b V2 n Any connectPerim' opts n1 n2 a1 a2 = withName n1 $ \sub1 ->- withName n2 $ \sub2 ->- let [os, oe] = map location [sub1, sub2]- s = fromMaybe os (maxTraceP os (unitX # rotate a1) sub1)- e = fromMaybe oe (maxTraceP oe (unitX # rotate a2) sub2)- in atop (arrowBetween' opts s e)+ withName n2 $ \sub2 ->+ let (os, oe) = over both location (sub1, sub2)+ s = fromMaybe os (maxTraceP os (unitX # rotate a1) sub1)+ e = fromMaybe oe (maxTraceP oe (unitX # rotate a2) sub2)+ in atop (arrowBetween' opts s e) -- | Draw an arrow from diagram named "n1" to diagram named "n2". The -- arrow lies on the line between the centres of the diagrams, but is -- drawn so that it stops at the boundaries of the diagrams, using traces -- to find the intersection points.-connectOutside- :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2)- => n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any+connectOutside ::+ (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) =>+ n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any connectOutside = connectOutside' def -connectOutside'- :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2)- => ArrowOpts n -> n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any+connectOutside' ::+ (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) =>+ ArrowOpts n -> n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any connectOutside' opts n1 n2 = withName n1 $ \b1 ->- withName n2 $ \b2 ->- let v = location b2 .-. location b1- midpoint = location b1 .+^ (v ^/ 2)- s' = fromMaybe (location b1) $ traceP midpoint (negated v) b1- e' = fromMaybe (location b2) $ traceP midpoint v b2- in- atop (arrowBetween' opts s' e')+ withName n2 $ \b2 ->+ let v = location b2 .-. location b1+ midpoint = location b1 .+^ (v ^/ 2)+ s' = fromMaybe (location b1) $ traceP midpoint (negated v) b1+ e' = fromMaybe (location b2) $ traceP midpoint v b2+ in atop (arrowBetween' opts s' e')
src/Diagrams/TwoD/Arrowheads.hs view
@@ -1,10 +1,14 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module : Diagrams.TwoD.Arrowheads -- Copyright : (c) 2013 diagrams-lib team (see LICENSE)@@ -14,77 +18,75 @@ -- Standard arrowheads and tails. Each arrowhead or tail is designed -- to be drawn filled, with a line width of 0, and is normalized to -- fit inside a circle of diameter 1.---------------------------------------------------------------------------------+module Diagrams.TwoD.Arrowheads (+ -- * Arrowheads -module Diagrams.TwoD.Arrowheads- (- -- * Arrowheads- -- ** Standard arrowheads- tri- , dart- , halfDart- , spike- , thorn- , lineHead- , noHead+ -- ** Standard arrowheads+ tri,+ dart,+ halfDart,+ spike,+ thorn,+ lineHead,+ noHead, - -- ** Configurable arrowheads- -- | Creates arrowheads of the same shape as the standard heads but- -- where the angle parameter is used to specify the angle to the top- -- left point of the arrowhead.- , arrowheadTriangle- , arrowheadDart- , arrowheadHalfDart- , arrowheadSpike- , arrowheadThorn+ -- ** Configurable arrowheads - -- * Arrow tails- -- ** Standard arrow tails- , tri'- , dart'- , halfDart'- , spike'- , thorn'- , lineTail- , noTail- , quill- , block+ -- | Creates arrowheads of the same shape as the standard heads but+ -- where the angle parameter is used to specify the angle to the top+ -- left point of the arrowhead.+ arrowheadTriangle,+ arrowheadDart,+ arrowheadHalfDart,+ arrowheadSpike,+ arrowheadThorn, - -- ** Configurable arrow tails+ -- * Arrow tails - , arrowtailQuill- , arrowtailBlock+ -- ** Standard arrow tails+ tri',+ dart',+ halfDart',+ spike',+ thorn',+ lineTail,+ noTail,+ quill,+ block, - -- * Internals- , ArrowHT- ) where+ -- ** Configurable arrow tails+ arrowtailQuill,+ arrowtailBlock, -import Control.Lens ((&), (.~), (<>~), (^.))-import Data.Default-import Data.Monoid (mempty, (<>))+ -- * Internals+ ArrowHT,+) where -import Diagrams.Angle-import Diagrams.Core+import Control.Lens (both, over, (&), (.~), (<>~), (^.))+import Data.Default+import Data.Monoid (mempty, (<>)) -import Diagrams.Path-import Diagrams.Segment-import Diagrams.Trail-import Diagrams.TrailLike (fromOffsets)-import Diagrams.TwoD.Align-import Diagrams.TwoD.Arc (arc')-import Diagrams.TwoD.Path ()-import Diagrams.TwoD.Polygons-import Diagrams.TwoD.Shapes-import Diagrams.TwoD.Transform-import Diagrams.TwoD.Types-import Diagrams.TwoD.Vector (unitX, unit_X, xDir)-import Diagrams.Util (( # ))+import Diagrams.Angle+import Diagrams.Core -import Linear.Affine-import Linear.Metric-import Linear.Vector+import Diagrams.Path+import Diagrams.Segment+import Diagrams.Trail+import Diagrams.TrailLike (fromOffsets)+import Diagrams.TwoD.Align+import Diagrams.TwoD.Arc (arc')+import Diagrams.TwoD.Path ()+import Diagrams.TwoD.Polygons+import Diagrams.TwoD.Shapes+import Diagrams.TwoD.Transform+import Diagrams.TwoD.Types+import Diagrams.TwoD.Vector (unitX, unit_X, xDir)+import Diagrams.Util ((#)) +import Linear.Affine+import Linear.Metric+import Linear.Vector+ ----------------------------------------------------------------------------- type ArrowHT n = n -> n -> (Path V2 n, Path V2 n)@@ -108,106 +110,121 @@ -- > <> square 0.6 # alignL # lw none # frame 0.1 arrowheadTriangle :: RealFloat n => Angle n -> ArrowHT n arrowheadTriangle theta = aHead- where- aHead len _ = (p, mempty)- where- psi = pi - (theta ^. rad)- r = len / (1 + cos psi)- p = polygon (def & polyType .~ PolyPolar [theta, (-2) *^ theta]- (repeat r) & polyOrient .~ NoOrient) # alignL-+ where+ aHead len _ = (p, mempty)+ where+ psi = pi - (theta ^. rad)+ r = len / (1 + cos psi)+ p =+ polygon+ ( def+ & polyType+ .~ PolyPolar+ [theta, (-2) *^ theta]+ (repeat r)+ & polyOrient .~ NoOrient+ )+ # alignL -- | Isoceles triangle with linear concave base. Inkscape type 1 - dart like. arrowheadDart :: RealFloat n => Angle n -> ArrowHT n arrowheadDart theta len shaftWidth = (hd # scale sz, jt)- where- hd = snugL . pathFromTrail . glueTrail $ fromOffsets [t1, t2, b2, b1]- jt = pathFromTrail . glueTrail $ j <> reflectY j- j = closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 (shaftWidth / 2)]- v = rotate theta unitX- (t1, t2) = (unit_X ^+^ v, V2 (-0.5) 0 ^-^ v)- [b1, b2] = map (reflectY . negated) [t1, t2]- psi = pi - negated t2 ^. _theta . rad- jLength = shaftWidth / (2 * tan psi)+ where+ hd = snugL . pathFromTrail . glueTrail $ fromOffsets [t1, t2, b2, b1]+ jt = pathFromTrail . glueTrail $ j <> reflectY j+ j = closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 (shaftWidth / 2)]+ v = rotate theta unitX+ (t1, t2) = (unit_X ^+^ v, V2 (-0.5) 0 ^-^ v)+ (b1, b2) = over both (reflectY . negated) (t1, t2)+ psi = pi - negated t2 ^. _theta . rad+ jLength = shaftWidth / (2 * tan psi) - -- If the shaft is too wide, set the size to a default value of 1.- sz = max 1 ((len - jLength) / 1.5)+ -- If the shaft is too wide, set the size to a default value of 1.+ sz = max 1 ((len - jLength) / 1.5) -- | Top half of an 'arrowheadDart'. arrowheadHalfDart :: RealFloat n => Angle n -> ArrowHT n arrowheadHalfDart theta len shaftWidth = (hd, jt)- where- hd = fromOffsets [t1, t2]- # closeTrail # pathFromTrail- # translateX 1.5 # scale sz- # translateY (-shaftWidth/2)- # snugL- jt = snugR . translateY (-shaftWidth/2) . pathFromTrail . closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 shaftWidth]- v = rotate theta unitX- (t1, t2) = (unit_X ^+^ v, (0.5 *^ unit_X) ^-^ v)- psi = pi - negated t2 ^. _theta . rad- jLength = shaftWidth / tan psi+ where+ hd =+ fromOffsets [t1, t2]+ # closeTrail+ # pathFromTrail+ # translateX 1.5+ # scale sz+ # translateY (-shaftWidth / 2)+ # snugL+ jt = snugR . translateY (-shaftWidth / 2) . pathFromTrail . closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 shaftWidth]+ v = rotate theta unitX+ (t1, t2) = (unit_X ^+^ v, (0.5 *^ unit_X) ^-^ v)+ psi = pi - negated t2 ^. _theta . rad+ jLength = shaftWidth / tan psi - -- If the shaft is too wide, set the size to a default value of 1.- sz = max 1 ((len - jLength) / 1.5)+ -- If the shaft is too wide, set the size to a default value of 1.+ sz = max 1 ((len - jLength) / 1.5) -- | Isoceles triangle with curved concave base. Inkscape type 2. arrowheadSpike :: RealFloat n => Angle n -> ArrowHT n-arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r)- where- hd = snugL . closedPath $ l1 <> c <> l2- jt = alignR . centerY . pathFromTrail- . closeTrail $ arc' 1 (xDir & _theta <>~ negated phi) (2 *^ phi)- l1 = trailFromSegments [straight $ unit_X ^+^ v]- l2 = trailFromSegments [reverseSegment . straight $ (unit_X ^+^ reflectY v)]- c = arc' 1 (rotate α xDir) ((-2) *^ α)- α = (1/2 @@ turn) ^-^ theta- v = rotate theta unitX+arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r)+ where+ hd = snugL . closedPath $ l1 <> c <> l2+ jt =+ alignR+ . centerY+ . pathFromTrail+ . closeTrail+ $ arc' 1 (xDir & _theta <>~ negated phi) (2 *^ phi)+ l1 = trailFromSegments [straight $ unit_X ^+^ v]+ l2 = trailFromSegments [reverseSegment . straight $ (unit_X ^+^ reflectY v)]+ c = arc' 1 (rotate α xDir) ((-2) *^ α)+ α = (1 / 2 @@ turn) ^-^ theta+ v = rotate theta unitX - -- The length of the head without its joint is, -2r cos theta and- -- the length of the joint is r - sqrt (r^2 - y^2). So the total- -- length of the arrow head is given by r(1 - 2 cos theta)-sqrt (r^2-y^2).- -- Solving the quadratic gives two roots, we want the larger one.+ -- The length of the head without its joint is, -2r cos theta and+ -- the length of the joint is r - sqrt (r^2 - y^2). So the total+ -- length of the arrow head is given by r(1 - 2 cos theta)-sqrt (r^2-y^2).+ -- Solving the quadratic gives two roots, we want the larger one. - -- 1/4 turn < theta < 2/3 turn.- a = 1 - 2 * cos (theta ^. rad)- y = shaftWidth / 2+ -- 1/4 turn < theta < 2/3 turn.+ a = 1 - 2 * cos (theta ^. rad)+ y = shaftWidth / 2 - -- If the shaft is too wide for the head, we default the radius r to- -- 2/3 * len by setting d=1 and phi=pi/2.- d = max 1 (len**2 + (1 - a**2) * y**2)- r = (a * len + sqrt d) / (a**2 -1)- phi = asinA (min 1 (y/r))+ -- If the shaft is too wide for the head, we default the radius r to+ -- 2/3 * len by setting d=1 and phi=pi/2.+ d = max 1 (len ** 2 + (1 - a ** 2) * y ** 2)+ r = (a * len + sqrt d) / (a ** 2 - 1)+ phi = asinA (min 1 (y / r)) -- | Curved sides, linear concave base. Illustrator CS5 #3 arrowheadThorn :: RealFloat n => Angle n -> ArrowHT n arrowheadThorn theta len shaftWidth = (hd # scale sz, jt)- where- hd = snugL . pathFromTrail . glueTrail $ hTop <> reflectY hTop- hTop = closeTrail . trailFromSegments $ [c, l]- jt = pathFromTrail . glueTrail $ j <> reflectY j- j = closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 (shaftWidth / 2)]- c = curvedSide theta- v = rotate theta unitX- l = reverseSegment . straight $ t- t = v ^-^ V2 (-0.5) 0- psi = fullTurn ^/ 2 ^-^ (negated t ^. _theta)- jLength = shaftWidth / (2 * tanA psi)+ where+ hd = snugL . pathFromTrail . glueTrail $ hTop <> reflectY hTop+ hTop = closeTrail . trailFromSegments $ [c, l]+ jt = pathFromTrail . glueTrail $ j <> reflectY j+ j = closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 (shaftWidth / 2)]+ c = curvedSide theta+ v = rotate theta unitX+ l = reverseSegment . straight $ t+ t = v ^-^ V2 (-0.5) 0+ psi = fullTurn ^/ 2 ^-^ (negated t ^. _theta)+ jLength = shaftWidth / (2 * tanA psi) - -- If the shaft if too wide, set the size to a default value of 1.- sz = max 1 ((len - jLength) / 1.5)+ -- If the shaft if too wide, set the size to a default value of 1.+ sz = max 1 ((len - jLength) / 1.5) -- | Make a side for the thorn head. curvedSide :: Floating n => Angle n -> Segment Closed V2 n curvedSide theta = bezier3 ctrl1 ctrl2 end- where- v0 = unit_X- v1 = rotate theta unitX- ctrl1 = v0- ctrl2 = v0 ^+^ v1- end = v0 ^+^ v1+ where+ v0 = unit_X+ v1 = rotate theta unitX+ ctrl1 = v0+ ctrl2 = v0 ^+^ v1+ end = v0 ^+^ v1 -- Standard heads ---------------------------------------------------------+ -- | A line the same width as the shaft. lineHead :: RealFloat n => ArrowHT n lineHead s w = (square 1 # scaleX s # scaleY w # alignL, mempty)@@ -219,31 +236,31 @@ -- > triEx = drawHead tri tri :: RealFloat n => ArrowHT n-tri = arrowheadTriangle (1/3 @@ turn)+tri = arrowheadTriangle (1 / 3 @@ turn) -- | <<diagrams/src_Diagrams_TwoD_Arrowheads_spikeEx.svg#diagram=spikeEx&width=100>> -- > spikeEx = drawHead spike spike :: RealFloat n => ArrowHT n-spike = arrowheadSpike (3/8 @@ turn)+spike = arrowheadSpike (3 / 8 @@ turn) -- | <<diagrams/src_Diagrams_TwoD_Arrowheads_thornEx.svg#diagram=thornEx&width=100>> -- > thornEx = drawHead thorn thorn :: RealFloat n => ArrowHT n-thorn = arrowheadThorn (3/8 @@ turn)+thorn = arrowheadThorn (3 / 8 @@ turn) -- | <<diagrams/src_Diagrams_TwoD_Arrowheads_dartEx.svg#diagram=dartEx&width=100>> -- > dartEx = drawHead dart dart :: RealFloat n => ArrowHT n-dart = arrowheadDart (2/5 @@ turn)+dart = arrowheadDart (2 / 5 @@ turn) -- | <<diagrams/src_Diagrams_TwoD_Arrowheads_halfDartEx.svg#diagram=halfDartEx&width=100>> -- > halfDartEx = drawHead halfDart halfDart :: RealFloat n => ArrowHT n-halfDart = arrowheadHalfDart (2/5 @@ turn)+halfDart = arrowheadHalfDart (2 / 5 @@ turn) -- Tails ------------------------------------------------------------------ -- > drawTail t = arrowAt' (with & arrowTail .~ t & shaftStyle %~ lw none@@ -255,47 +272,50 @@ -- attached at the start of the trail. headToTail :: OrderedField n => ArrowHT n -> ArrowHT n headToTail hd = tl- where- tl sz shaftWidth = (t, j)- where- (t', j') = hd sz shaftWidth- t = reflectX t'- j = reflectX j'+ where+ tl sz shaftWidth = (t, j)+ where+ (t', j') = hd sz shaftWidth+ t = reflectX t'+ j = reflectX j' -arrowtailBlock :: forall n. (RealFloat n) => Angle n -> ArrowHT n+arrowtailBlock :: forall n. RealFloat n => Angle n -> ArrowHT n arrowtailBlock theta = aTail- where- aTail len _ = (t, mempty)- where- t = rect len (len * x) # alignR- a' :: V2 n- a' = rotate theta unitX- a = a' ^-^ reflectY a'- x = norm a+ where+ aTail len _ = (t, mempty)+ where+ t = rect len (len * x) # alignR+ a' :: V2 n+ a' = rotate theta unitX+ a = a' ^-^ reflectY a'+ x = norm a -- | The angle is where the top left corner intersects the circle. arrowtailQuill :: OrderedField n => Angle n -> ArrowHT n arrowtailQuill theta = aTail- where- aTail len shaftWidth = (t, j)- where- t = closedPath (trailFromVertices [v0, v1, v2, v3, v4, v5, v0])- # scale sz # alignR- sz = len / 0.6- v0 = p2 (0.5, 0)- v2 = origin .+^ (rotate theta unitX # scale 0.5)- v1 = v2 # translateX (5/8)- v3 = p2 (-0.1, 0)- v4 = v2 # reflectY- v5 = v4 # translateX (5/8)- s = 1 - shaftWidth / norm (v1 .-. v5)- n1 = v0 # translateY (0.5 * shaftWidth)- n2 = v1 .-^ ((v1 .-. v0) # scale s)- n3 = v5 .-^ ((v5 .-. v0) # scale s)- n4 = n1 # reflectY- j = closedPath $ trailFromVertices [v0, n1, n2, v0, n3, n4, v0]+ where+ aTail len shaftWidth = (t, j)+ where+ t =+ closedPath (trailFromVertices [v0, v1, v2, v3, v4, v5, v0])+ # scale sz+ # alignR+ sz = len / 0.6+ v0 = p2 (0.5, 0)+ v2 = origin .+^ (rotate theta unitX # scale 0.5)+ v1 = v2 # translateX (5 / 8)+ v3 = p2 (-0.1, 0)+ v4 = v2 # reflectY+ v5 = v4 # translateX (5 / 8)+ s = 1 - shaftWidth / norm (v1 .-. v5)+ n1 = v0 # translateY (0.5 * shaftWidth)+ n2 = v1 .-^ ((v1 .-. v0) # scale s)+ n3 = v5 .-^ ((v5 .-. v0) # scale s)+ n4 = n1 # reflectY+ j = closedPath $ trailFromVertices [v0, n1, n2, v0, n3, n4, v0] -- Standard tails ---------------------------------------------------------+ -- | A line the same width as the shaft. lineTail :: RealFloat n => ArrowHT n lineTail s w = (square 1 # scaleY w # scaleX s # alignR, mempty)@@ -337,10 +357,10 @@ -- > quillEx = drawTail quill quill :: (Floating n, Ord n) => ArrowHT n-quill = arrowtailQuill (2/5 @@ turn)+quill = arrowtailQuill (2 / 5 @@ turn) -- | <<diagrams/src_Diagrams_TwoD_Arrowheads_blockEx.svg#diagram=blockEx&width=100>> -- > blockEx = drawTail block block :: RealFloat n => ArrowHT n-block = arrowtailBlock (7/16 @@ turn)+block = arrowtailBlock (7 / 16 @@ turn)
src/Diagrams/TwoD/Attributes.hs view
@@ -1,17 +1,19 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module : Diagrams.TwoD.Attributes -- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE)@@ -25,60 +27,93 @@ -- 'FillColor' and 'LineColor' attributes are provided so that backends that -- don't support gradients need not be concerned with using textures. Backends -- should only implement color attributes or textures attributes, not both.---------------------------------------------------------------------------------- module Diagrams.TwoD.Attributes ( -- * Textures- Texture(..), solid, _SC, _AC, _LG, _RG, defaultLG, defaultRG- , GradientStop(..), stopColor, stopFraction, mkStops- , SpreadMethod(..), lineLGradient, lineRGradient+ Texture (..),+ solid,+ _SC,+ _AC,+ _LG,+ _RG,+ defaultLG,+ defaultRG,+ GradientStop (..),+ stopColor,+ stopFraction,+ mkStops,+ SpreadMethod (..),+ lineLGradient,+ lineRGradient, -- ** Linear Gradients- , LGradient(..), lGradStops, lGradTrans, lGradStart, lGradEnd- , lGradSpreadMethod, mkLinearGradient+ LGradient (..),+ lGradStops,+ lGradTrans,+ lGradStart,+ lGradEnd,+ lGradSpreadMethod,+ mkLinearGradient, -- ** Radial Gradients- , RGradient(..), rGradStops, rGradTrans- , rGradCenter0, rGradRadius0, rGradCenter1, rGradRadius1- , rGradSpreadMethod, mkRadialGradient+ RGradient (..),+ rGradStops,+ rGradTrans,+ rGradCenter0,+ rGradRadius0,+ rGradCenter1,+ rGradRadius1,+ rGradSpreadMethod,+ mkRadialGradient, -- ** Line texture- , LineTexture(..), _LineTexture, getLineTexture, lineTexture, lineTextureA- , mkLineTexture, _lineTexture+ LineTexture (..),+ _LineTexture,+ getLineTexture,+ lineTexture,+ lineTextureA,+ mkLineTexture,+ _lineTexture, -- ** Line color- , lineColor, lc, lcA+ lineColor,+ lc,+ lcA, -- ** Fill texture- , FillTexture(..), _FillTexture, getFillTexture, fillTexture- , mkFillTexture, _fillTexture, _fillTextureR+ FillTexture (..),+ _FillTexture,+ getFillTexture,+ fillTexture,+ mkFillTexture,+ _fillTexture,+ _fillTextureR, -- ** Fill color- , fillColor, fc, fcA, recommendFillColor+ fillColor,+ fc,+ fcA,+ recommendFillColor, -- * Compilation utilities- , splitTextureFills-- ) where--import Control.Lens hiding (transform)-import Data.Colour hiding (AffineSpace, over)-import Data.Data-import Data.Default-import Data.Monoid.Recommend-import Data.Semigroup+ splitTextureFills,+) where -import Diagrams.Attributes-import Diagrams.Attributes.Compile-import Diagrams.Core-import Diagrams.Core.Types (RTree)-import Diagrams.Located (unLoc)-import Diagrams.Path (Path, pathTrails)-import Diagrams.Trail (isLoop)-import Diagrams.TwoD.Types-import Diagrams.Util+import Control.Lens hiding (transform)+import Data.Colour hiding (AffineSpace, over)+import Data.Data+import Data.Default+import Data.Monoid.Recommend+import Data.Semigroup +import Diagrams.Attributes+import Diagrams.Attributes.Compile+import Diagrams.Core+import Diagrams.Core.Types (RTree)+import Diagrams.Located (unLoc)+import Diagrams.Path (Path, pathTrails)+import Diagrams.Trail (isLoop)+import Diagrams.TwoD.Types+import Diagrams.Util ----------------------------------------------------------------- -- Gradients --------------------------------------------------@@ -86,7 +121,7 @@ -- | A gradient stop contains a color and fraction (usually between 0 and 1) data GradientStop d = GradientStop- { _stopColor :: SomeColor+ { _stopColor :: SomeColor , _stopFraction :: d } @@ -107,11 +142,12 @@ -- | Linear Gradient data LGradient n = LGradient- { _lGradStops :: [GradientStop n]- , _lGradStart :: Point V2 n- , _lGradEnd :: Point V2 n- , _lGradTrans :: Transformation V2 n- , _lGradSpreadMethod :: SpreadMethod }+ { _lGradStops :: [GradientStop n]+ , _lGradStart :: Point V2 n+ , _lGradEnd :: Point V2 n+ , _lGradTrans :: Transformation V2 n+ , _lGradSpreadMethod :: SpreadMethod+ } type instance V (LGradient n) = V2 type instance N (LGradient n) = n@@ -142,13 +178,14 @@ -- | Radial Gradient data RGradient n = RGradient- { _rGradStops :: [GradientStop n]- , _rGradCenter0 :: Point V2 n- , _rGradRadius0 :: n- , _rGradCenter1 :: Point V2 n- , _rGradRadius1 :: n- , _rGradTrans :: Transformation V2 n- , _rGradSpreadMethod :: SpreadMethod }+ { _rGradStops :: [GradientStop n]+ , _rGradCenter0 :: Point V2 n+ , _rGradRadius0 :: n+ , _rGradCenter1 :: Point V2 n+ , _rGradRadius1 :: n+ , _rGradTrans :: Transformation V2 n+ , _rGradSpreadMethod :: SpreadMethod+ } makeLensesWith (lensRules & generateSignatures .~ False) ''RGradient @@ -168,7 +205,7 @@ rGradRadius0 :: Lens' (RGradient n) n -- | The center of the outer circle.-rGradCenter1 :: Lens' (RGradient n) (Point V2 n)+rGradCenter1 :: Lens' (RGradient n) (Point V2 n) -- | The radius of the outer circle in 'local' coordinates. rGradRadius1 :: Lens' (RGradient n) n@@ -189,7 +226,6 @@ -- An object can have only one texture which is determined by the 'Last' -- semigroup structure. data Texture n = SC SomeColor | LG (LGradient n) | RG (RGradient n)- deriving Typeable type instance V (Texture n) = V2 type instance N (Texture n) = n@@ -203,7 +239,7 @@ instance Floating n => Transformable (Texture n) where transform t (LG lg) = LG $ transform t lg transform t (RG rg) = RG $ transform t rg- transform _ sc = sc+ transform _ sc = sc -- | Convert a solid colour into a texture. solid :: Color a => a -> Texture n@@ -214,28 +250,32 @@ -- no default value is provided for @lGradStops@, this must be set before -- the gradient value is used, otherwise the object will appear transparent. defaultLG :: Fractional n => Texture n-defaultLG = LG LGradient- { _lGradStops = []- , _lGradStart = mkP2 (-0.5) 0- , _lGradEnd = mkP2 0.5 0- , _lGradTrans = mempty- , _lGradSpreadMethod = GradPad- }+defaultLG =+ LG+ LGradient+ { _lGradStops = []+ , _lGradStart = mkP2 (-0.5) 0+ , _lGradEnd = mkP2 0.5 0+ , _lGradTrans = mempty+ , _lGradSpreadMethod = GradPad+ } -- | A default is provided so that radial gradients can easily be created using -- lenses. For example, @rg = defaultRG & rGradRadius1 .~ 0.25@. Note that -- no default value is provided for @rGradStops@, this must be set before -- the gradient value is used, otherwise the object will appear transparent. defaultRG :: Fractional n => Texture n-defaultRG = RG RGradient- { _rGradStops = []- , _rGradCenter0 = mkP2 0 0- , _rGradRadius0 = 0.0- , _rGradCenter1 = mkP2 0 0- , _rGradRadius1 = 0.5- , _rGradTrans = mempty- , _rGradSpreadMethod = GradPad- }+defaultRG =+ RG+ RGradient+ { _rGradStops = []+ , _rGradCenter0 = mkP2 0 0+ , _rGradRadius0 = 0.0+ , _rGradCenter1 = mkP2 0 0+ , _rGradRadius1 = 0.5+ , _rGradTrans = mempty+ , _rGradSpreadMethod = GradPad+ } -- | A convenient function for making gradient stops from a list of triples. -- (An opaque color, a stop fraction, an opacity).@@ -246,16 +286,23 @@ -- and 'SpreadMethod'. The 'lGradTrans' field is set to the identity -- transfrom, to change it use the 'lGradTrans' lens. mkLinearGradient :: Num n => [GradientStop n] -> Point V2 n -> Point V2 n -> SpreadMethod -> Texture n-mkLinearGradient stops start end spreadMethod- = LG (LGradient stops start end mempty spreadMethod)+mkLinearGradient stops start end spreadMethod =+ LG (LGradient stops start end mempty spreadMethod) -- | Make a radial gradient texture from a stop list, radius, start point, -- end point, and 'SpreadMethod'. The 'rGradTrans' field is set to the identity -- transfrom, to change it use the 'rGradTrans' lens.-mkRadialGradient :: Num n => [GradientStop n] -> Point V2 n -> n- -> Point V2 n -> n -> SpreadMethod -> Texture n-mkRadialGradient stops c0 r0 c1 r1 spreadMethod- = RG (RGradient stops c0 r0 c1 r1 mempty spreadMethod)+mkRadialGradient ::+ Num n =>+ [GradientStop n] ->+ Point V2 n ->+ n ->+ Point V2 n ->+ n ->+ SpreadMethod ->+ Texture n+mkRadialGradient stops c0 r0 c1 r1 spreadMethod =+ RG (RGradient stops c0 r0 c1 r1 mempty spreadMethod) -- Line Texture -------------------------------------------------------- @@ -264,14 +311,19 @@ -- More precisely, the semigroup structure on line texture attributes -- is that of 'Last'. newtype LineTexture n = LineTexture (Last (Texture n))- deriving (Typeable, Semigroup)-instance (Typeable n) => AttributeClass (LineTexture n)+ deriving (Semigroup) +instance Typeable n => AttributeClass (LineTexture n)+ type instance V (LineTexture n) = V2 type instance N (LineTexture n) = n -_LineTexture :: Iso (LineTexture n) (LineTexture n')- (Texture n) (Texture n')+_LineTexture ::+ Iso+ (LineTexture n)+ (LineTexture n')+ (Texture n)+ (Texture n') _LineTexture = iso getLineTexture (LineTexture . Last) -- Only gradients get transformed. The transform is applied to the gradients@@ -296,8 +348,8 @@ _lineTexture :: (Floating n, Typeable n) => Lens' (Style V2 n) (Texture n) _lineTexture = atTAttr . anon def isDef . _LineTexture- where- isDef = anyOf (_LineTexture . _AC) (== opaque black)+ where+ isDef = anyOf (_LineTexture . _AC) (== opaque black) -- | Set the line (stroke) color. This function is polymorphic in the -- color type (so it can be used with either 'Colour' or@@ -332,20 +384,21 @@ -- The semigroup structure on fill texture attributes -- is that of 'Recommed . Last'. newtype FillTexture n = FillTexture (Recommend (Last (Texture n)))- deriving (Typeable, Semigroup)+ deriving (Semigroup) instance Typeable n => AttributeClass (FillTexture n) _FillTexture :: Iso' (FillTexture n) (Recommend (Texture n)) _FillTexture = iso getter setter- where- getter (FillTexture (Recommend (Last t))) = Recommend t- getter (FillTexture (Commit (Last t))) = Commit t- setter (Recommend t) = FillTexture (Recommend (Last t))- setter (Commit t) = FillTexture (Commit (Last t))- -- = iso (\(FillTexture a) -> a) FillTexture . mapping _Wrapped- -- -- once we depend on monoid-extras-0.4+ where+ getter (FillTexture (Recommend (Last t))) = Recommend t+ getter (FillTexture (Commit (Last t))) = Commit t+ setter (Recommend t) = FillTexture (Recommend (Last t))+ setter (Commit t) = FillTexture (Commit (Last t)) +-- = iso (\(FillTexture a) -> a) FillTexture . mapping _Wrapped+-- -- once we depend on monoid-extras-0.4+ type instance V (FillTexture n) = V2 type instance N (FillTexture n) = n @@ -369,8 +422,8 @@ -- | Lens onto the 'Recommend' of a fill texture in a style. _fillTextureR :: (Typeable n, Floating n) => Lens' (Style V2 n) (Recommend (Texture n)) _fillTextureR = atTAttr . anon def isDef . _FillTexture- where- isDef = anyOf (_FillTexture . _Recommend . _AC) (== transparent)+ where+ isDef = anyOf (_FillTexture . _Recommend . _AC) (== transparent) -- | Commit a fill texture in a style. This is /not/ a valid setter -- because it doesn't abide the functor law (see 'committed').@@ -414,10 +467,11 @@ -- | Push fill attributes down until they are at the root of subtrees -- containing only loops. This makes life much easier for backends, -- which typically have a semantics where fill attributes are--- applied to lines/non-closed paths as well as loops/closed paths,+-- applied to lines\/non-closed paths as well as loops\/closed paths, -- whereas in the semantics of diagrams, fill attributes only apply -- to loops.-splitTextureFills- :: forall b v n a. (- Typeable n) => RTree b v n a -> RTree b v n a+splitTextureFills ::+ forall b v n a.+ Typeable n =>+ RTree b v n a -> RTree b v n a splitTextureFills = splitAttr (FillTextureLoops :: FillTextureLoops n)
src/Diagrams/TwoD/Image.hs view
@@ -1,13 +1,16 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module : Diagrams.TwoD.Image -- Copyright : (c) 2011 diagrams-lib team (see LICENSE)@@ -19,70 +22,71 @@ -- according to the aspect ratio, use @image img # scaleUToX 1@, where -- @img@ is a value of type @DImage n e@, created with a function like -- 'loadImageEmb', 'loadImageExt', or 'raster'.--------------------------------------------------------------------------------module Diagrams.TwoD.Image- (- DImage(..), ImageData(..)- , Embedded, External, Native- , image- , embeddedImage- , loadImageEmb- , loadImageEmbBS- , loadImageExt- , uncheckedImageRef- , raster- , rasterDia- ) where+module Diagrams.TwoD.Image (+ DImage (..),+ ImageData (..),+ Embedded,+ External,+ Native,+ image,+ embeddedImage,+ loadImageEmb,+ loadImageEmbBS,+ loadImageExt,+ uncheckedImageRef,+ raster,+ rasterDia,+) where -import Codec.Picture+import Codec.Picture -import Data.Colour (AlphaColour)-import Data.Kind (Type)-import Data.Semigroup-import Data.Typeable (Typeable)+import Data.Colour (AlphaColour)+import Data.Kind (Type)+import Data.Semigroup+import Data.Typeable (Typeable) -import Diagrams.Core+import Diagrams.Core -import Diagrams.Attributes (colorToSRGBA)-import Diagrams.Path (Path)-import Diagrams.Query-import Diagrams.TwoD.Path (isInsideEvenOdd)-import Diagrams.TwoD.Shapes (rect)-import Diagrams.TwoD.Types+import Diagrams.Attributes (colorToSRGBA)+import Diagrams.Path (Path)+import Diagrams.Query+import Diagrams.TwoD.Path (isInsideEvenOdd)+import Diagrams.TwoD.Shapes (rect)+import Diagrams.TwoD.Types -import Data.ByteString+import Data.ByteString -import Linear.Affine+import Linear.Affine -data Embedded deriving Typeable-data External deriving Typeable-data Native (t :: Type) deriving Typeable+data Embedded+data External+data Native (t :: Type) -- | 'ImageData' is either a JuicyPixels @DynamicImage@ tagged as 'Embedded' or -- a reference tagged as 'External'. Additionally 'Native' is provided for -- external libraries to hook into. data ImageData :: Type -> Type where ImageRaster :: DynamicImage -> ImageData Embedded- ImageRef :: FilePath -> ImageData External+ ImageRef :: FilePath -> ImageData External ImageNative :: t -> ImageData (Native t) -------------------------------------------------------------------------------+ -- | An image primitive, the two ints are width followed by height. -- Will typically be created by @loadImageEmb@ or @loadImageExt@ which, -- will handle setting the width and height to the actual width and height -- of the image. data DImage :: Type -> Type -> Type where DImage :: ImageData t -> Int -> Int -> Transformation V2 n -> DImage n t- deriving Typeable type instance V (DImage n a) = V2 type instance N (DImage n a) = n instance RealFloat n => HasQuery (DImage n a) Any where- getQuery (DImage _ w h _) = -- transform t $+ getQuery (DImage _ w h _) =+ -- transform t $ Query $ \p -> Any (isInsideEvenOdd r p)- where+ where r = rectPath (fromIntegral w) (fromIntegral h) instance Fractional n => Transformable (DImage n a) where@@ -92,18 +96,20 @@ moveOriginTo p = translate (origin .-. p) -- | Make a 'DImage' into a 'Diagram'.-image :: (TypeableFloat n, Typeable a, Renderable (DImage n a) b)- => DImage n a -> QDiagram b V2 n Any-image img- = mkQD (Prim img)- (getEnvelope r)- (getTrace r)- mempty- (Query $ \p -> Any (isInsideEvenOdd r p))- where- r = rectPath (fromIntegral w) (fromIntegral h)- -- should we use the transform here?- DImage _ w h _ = img+image ::+ (TypeableFloat n, Typeable a, Renderable (DImage n a) b) =>+ DImage n a -> QDiagram b V2 n Any+image img =+ mkQD+ (Prim img)+ (getEnvelope r)+ (getTrace r)+ mempty+ (Query $ \p -> Any (isInsideEvenOdd r p))+ where+ r = rectPath (fromIntegral w) (fromIntegral h)+ -- should we use the transform here?+ DImage _ w h _ = img rectPath :: RealFloat n => n -> n -> Path V2 n rectPath = rect@@ -112,9 +118,9 @@ -- The width and height of the image are set to their actual values. embeddedImage :: Num n => DynamicImage -> DImage n Embedded embeddedImage img = DImage (ImageRaster img) w h mempty- where- w = dynamicMap imageWidth img- h = dynamicMap imageHeight img+ where+ w = dynamicMap imageWidth img+ h = dynamicMap imageHeight img -- | Use JuicyPixels to read a file in any format and wrap it in a 'DImage'. -- The width and height of the image are set to their actual values.@@ -132,11 +138,11 @@ loadImageExt path = do dImg <- readImage path return $ case dImg of- Left msg -> Left msg+ Left msg -> Left msg Right img -> Right $ DImage (ImageRef path) w h mempty- where- w = dynamicMap imageWidth img- h = dynamicMap imageHeight img+ where+ w = dynamicMap imageWidth img+ h = dynamicMap imageHeight img -- | Make an "unchecked" image reference; have to specify a -- width and height. Unless the aspect ratio of the external@@ -145,24 +151,24 @@ uncheckedImageRef path w h = DImage (ImageRef path) w h mempty -- | Crate a diagram from raw raster data.-rasterDia :: (TypeableFloat n, Renderable (DImage n Embedded) b)- => (Int -> Int -> AlphaColour Double) -> Int -> Int -> QDiagram b V2 n Any+rasterDia ::+ (TypeableFloat n, Renderable (DImage n Embedded) b) =>+ (Int -> Int -> AlphaColour Double) -> Int -> Int -> QDiagram b V2 n Any rasterDia f w h = image $ raster f w h -- | Create an image "from scratch" by specifying the pixel data raster :: Num n => (Int -> Int -> AlphaColour Double) -> Int -> Int -> DImage n Embedded raster f w h = DImage (ImageRaster (ImageRGBA8 img)) w h mempty- where- img = generateImage g w h- g x y = fromAlphaColour $ f x y+ where+ img = generateImage g w h+ g x y = fromAlphaColour $ f x y fromAlphaColour :: AlphaColour Double -> PixelRGBA8 fromAlphaColour c = PixelRGBA8 r g b a- where- (r, g, b, a) = (int r', int g', int b', int a')- (r', g', b', a') = colorToSRGBA c- int x = round (255 * x)+ where+ (r, g, b, a) = (int r', int g', int b', int a')+ (r', g', b', a') = colorToSRGBA c+ int x = round (255 * x) instance Fractional n => (Renderable (DImage n a) NullBackend) where render _ _ = mempty-
src/Diagrams/TwoD/Offset.hs view
@@ -1,17 +1,16 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}-+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-}- -- for Data.Semigroup ------------------------------------------------------------------------------+-- for Data.Semigroup+ -- | -- Module : Diagrams.TwoD.Offset -- Copyright : (c) 2013 diagrams-lib team (see LICENSE)@@ -21,68 +20,70 @@ -- Compute offsets to segments in two dimensions. More details can be -- found in the manual at -- <https://diagrams.github.io/doc/manual.html#offsets-of-segments-trails-and-paths>.----------------------------------------------------------------------------------module Diagrams.TwoD.Offset- (- -- * Offsets-- offsetSegment-- , OffsetOpts(..), offsetJoin, offsetMiterLimit, offsetEpsilon- , offsetTrail- , offsetTrail'- , offsetPath- , offsetPath'-- -- * Expansions-- , ExpandOpts(..), expandJoin, expandMiterLimit, expandCap, expandEpsilon- , expandTrail- , expandTrail'- , expandPath- , expandPath'+module Diagrams.TwoD.Offset (+ -- * Offsets+ offsetSegment,+ OffsetOpts (..),+ offsetJoin,+ offsetMiterLimit,+ offsetEpsilon,+ offsetTrail,+ offsetTrail',+ offsetPath,+ offsetPath', - ) where+ -- * Expansions+ ExpandOpts (..),+ expandJoin,+ expandMiterLimit,+ expandCap,+ expandEpsilon,+ expandTrail,+ expandTrail',+ expandPath,+ expandPath',+) where -import Control.Applicative-import Control.Lens hiding (at)-import Prelude+import Control.Applicative+import Control.Lens hiding (at)+import Prelude -import Data.Maybe (catMaybes)-import Data.Monoid-import Data.Monoid.Inf+import Data.Maybe (catMaybes)+import Data.Monoid+import Data.Monoid.Inf -import Data.Default+import Data.Default -import Diagrams.Core+import Diagrams.Core -import Diagrams.Attributes-import Diagrams.Direction-import Diagrams.Located-import Diagrams.Parametric-import Diagrams.Path-import Diagrams.Segment-import Diagrams.Trail hiding (isLoop, offset)-import Diagrams.TrailLike-import Diagrams.TwoD.Arc-import Diagrams.TwoD.Curvature-import Diagrams.TwoD.Path ()-import Diagrams.TwoD.Types-import Diagrams.TwoD.Vector hiding (e)+import Diagrams.Attributes+import Diagrams.Direction+import Diagrams.Located+import Diagrams.Parametric+import Diagrams.Path+import Diagrams.Segment+import Diagrams.Trail hiding (isLoop, offset)+import Diagrams.TrailLike+import Diagrams.TwoD.Arc+import Diagrams.TwoD.Curvature+import Diagrams.TwoD.Path ()+import Diagrams.TwoD.Types+import Diagrams.TwoD.Vector hiding (e) -import Linear.Affine-import Linear.Metric-import Linear.Vector+import Linear.Affine+import Linear.Metric+import Linear.Vector unitPerp :: OrderedField n => V2 n -> V2 n unitPerp = signorm . perp perpAtParam :: OrderedField n => Segment Closed V2 n -> n -> V2 n perpAtParam (Linear (OffsetClosed a)) _ = negated $ unitPerp a-perpAtParam cubic t = negated $ unitPerp a- where- (Cubic a _ _) = snd $ splitAtParam cubic t+perpAtParam cubic t = negated $ unitPerp a+ where+ a = case snd $ splitAtParam cubic t of+ Cubic x _ _ -> x+ _ -> error "Impossible: splitAtParam on a cubic segment returned a non-cubic segment" -- | Compute the offset of a segment. Given a segment compute the offset -- curve that is a fixed distance from the original curve. For linear@@ -109,15 +110,14 @@ -- 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.--- -- | Options for specifying line join and segment epsilon for an offset -- involving multiple segments. data OffsetOpts d = OffsetOpts- { _offsetJoin :: LineJoin- , _offsetMiterLimit :: d- , _offsetEpsilon :: d- }+ { _offsetJoin :: LineJoin+ , _offsetMiterLimit :: d+ , _offsetEpsilon :: d+ } deriving instance Eq d => Eq (OffsetOpts d) deriving instance Show d => Show (OffsetOpts d)@@ -136,15 +136,16 @@ -- | The default offset options use the default 'LineJoin' ('LineJoinMiter'), a -- miter limit of 10, and epsilon factor of 0.01. instance Fractional d => Default (OffsetOpts d) where- def = OffsetOpts def 10 0.01+ def = OffsetOpts def 10 0.01 -- | Options for specifying how a 'Trail' should be expanded. data ExpandOpts d = ExpandOpts- { _expandJoin :: LineJoin- , _expandMiterLimit :: d- , _expandCap :: LineCap- , _expandEpsilon :: d- } deriving (Eq, Show)+ { _expandJoin :: LineJoin+ , _expandMiterLimit :: d+ , _expandCap :: LineCap+ , _expandEpsilon :: d+ }+ deriving (Eq, Show) makeLensesWith (lensRules & generateSignatures .~ False) ''ExpandOpts @@ -160,66 +161,70 @@ -- | Epsilon perimeter for 'offsetSegment'. expandEpsilon :: Lens' (ExpandOpts d) d -- -- | The default 'ExpandOpts' is the default 'LineJoin' ('LineJoinMiter'), -- miter limit of 10, default 'LineCap' ('LineCapButt'), and epsilon factor -- of 0.01.-instance (Fractional d) => Default (ExpandOpts d) where- def = ExpandOpts def 10 def 0.01--offsetSegment :: RealFloat n- => n -- ^ Epsilon factor that when multiplied to the- -- absolute value of the radius gives a- -- 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 factor from the radius of curvature of- -- the offset.- -> n -- ^ Offset from the original segment, positive is- -- on the right of the curve, negative is on the- -- left.- -> Segment Closed V2 n -- ^ Original segment- -> Located (Trail V2 n) -- ^ Resulting located (at the offset) trail.-offsetSegment _ r s@(Linear (OffsetClosed a)) = trailFromSegments [s] `at` origin .+^ va- where va = (-r) *^ unitPerp a+instance Fractional d => Default (ExpandOpts d) where+ def = ExpandOpts def 10 def 0.01 +offsetSegment ::+ RealFloat n =>+ -- | Epsilon factor that when multiplied to the+ -- absolute value of the radius gives a+ -- 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 factor from the radius of curvature of+ -- the offset.+ n ->+ -- | Offset from the original segment, positive is+ -- on the right of the curve, negative is on the+ -- left.+ n ->+ -- | Original segment+ Segment Closed V2 n ->+ -- | Resulting located (at the offset) trail.+ Located (Trail V2 n)+offsetSegment _ r s@(Linear (OffsetClosed a)) = trailFromSegments [s] `at` origin .+^ va+ where+ va = (-r) *^ unitPerp a offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = t `at` origin .+^ va- where- t = trailFromSegments (go (radiusOfCurvature s 0.5))- -- Perpendiculars to handles.- va = (-r) *^ unitPerp a- vc = (-r) *^ unitPerp (c ^-^ b)- -- Split segments.- ss = (\(x,y) -> [x,y]) $ splitAtParam s 0.5- subdivided = concatMap (trailSegments . unLoc . 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)+ where+ t = trailFromSegments (go (radiusOfCurvature s 0.5))+ -- Perpendiculars to handles.+ va = (-r) *^ unitPerp a+ vc = (-r) *^ unitPerp (c ^-^ b)+ -- Split segments.+ ss = (\(x, y) -> [x, y]) $ splitAtParam s 0.5+ subdivided = concatMap (trailSegments . unLoc . offsetSegment epsilon r) ss - -- 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+ -- Offset with handles scaled based on curvature.+ offset factor = bezier3 (a ^* factor) ((b ^-^ c) ^* factor ^+^ c ^+^ vc ^-^ va) (c ^+^ vc ^-^ va) - close = and [epsilon * abs r > norm (p o ^+^ va ^-^ p s ^-^ pp s)- | t' <- [0.25, 0.5, 0.75]- , let p = (`atParam` t')- , let pp = (r *^) . (`perpAtParam` t')- ]+ -- 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 * abs r > norm (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 -- >@@ -247,13 +252,14 @@ -- it into a space with translation. bindLoc :: (Transformable b, V a ~ V b, N a ~ N b, V a ~ V2, N a ~ n, Num n) => (a -> b) -> Located a -> b bindLoc f = join' . mapLoc f- where- join' (viewLoc -> (p,a)) = translate (p .-. origin) a+ where+ join' (viewLoc -> (p, a)) = translate (p .-. origin) a -- While we build offsets and expansions we will use the [Located (Segment Closed v)] -- and [Located (Trail V2 n)] intermediate representations.-locatedTrailSegments :: OrderedField n- => Located (Trail V2 n) -> [Located (Segment Closed V2 n)]+locatedTrailSegments ::+ OrderedField n =>+ Located (Trail V2 n) -> [Located (Segment Closed V2 n)] locatedTrailSegments t = zipWith at (trailSegments (unLoc t)) (trailPoints t) -- | Offset a 'Trail' with options and by a given radius. This generates a new@@ -273,23 +279,25 @@ -- while a negative radius gives an inner loop (both counter-clockwise). -- -- <<diagrams/src_Diagrams_TwoD_Offset_offsetTrailOuterExample.svg#diagram=offsetTrailOuterExample&width=300>>----offsetTrail' :: RealFloat n- => OffsetOpts n- -> n -- ^ Radius of offset. A negative value gives an offset on- -- the left for a line and on the inside for a counter-clockwise- -- loop.- -> Located (Trail V2 n)- -> Located (Trail V2 n)-offsetTrail' opts r t = joinSegments eps j isLoop (opts^.offsetMiterLimit) r ends . offset $ t- where- eps = opts^.offsetEpsilon- offset = map (bindLoc (offsetSegment eps r)) . locatedTrailSegments- ends | isLoop = (\(a:as) -> as ++ [a]) . trailPoints $ t- | otherwise = tail . trailPoints $ t- j = fromLineJoin (opts^.offsetJoin)+offsetTrail' ::+ RealFloat n =>+ OffsetOpts n ->+ -- | Radius of offset. A negative value gives an offset on+ -- the left for a line and on the inside for a counter-clockwise+ -- loop.+ n ->+ Located (Trail V2 n) ->+ Located (Trail V2 n)+offsetTrail' opts r t = joinSegments eps j isLoop (opts ^. offsetMiterLimit) r ends . offset $ t+ where+ eps = opts ^. offsetEpsilon+ offset = map (bindLoc (offsetSegment eps r)) . locatedTrailSegments+ ends+ | isLoop = rotateL . trailPoints $ t+ | otherwise = drop 1 . trailPoints $ t+ j = fromLineJoin (opts ^. offsetJoin) - isLoop = withTrail (const False) (const True) (unLoc t)+ isLoop = withTrail (const False) (const True) (unLoc t) -- | Offset a 'Trail' with the default options and a given radius. See 'offsetTrail''. offsetTrail :: RealFloat n => n -> Located (Trail V2 n) -> Located (Trail V2 n)@@ -297,9 +305,10 @@ -- | Offset a 'Path' by applying 'offsetTrail'' to each trail in the path. offsetPath' :: RealFloat n => OffsetOpts n -> n -> Path V2 n -> Path V2 n-offsetPath' opts r = mconcat- . map (bindLoc (trailLike . offsetTrail' opts r) . (`at` origin))- . op Path+offsetPath' opts r =+ mconcat+ . map (bindLoc (trailLike . offsetTrail' opts r) . (`at` origin))+ . op Path -- | Offset a 'Path' with the default options and given radius. See 'offsetPath''. offsetPath :: RealFloat n => n -> Path V2 n -> Path V2 n@@ -344,8 +353,8 @@ withTrailL :: (Located (Trail' Line V2 n) -> r) -> (Located (Trail' Loop V2 n) -> r) -> Located (Trail V2 n) -> r withTrailL f g l = withTrail (f . (`at` p)) (g . (`at` p)) (unLoc l)- where- p = loc l+ where+ p = loc l -- | Expand a 'Trail' with the given options and radius 'r' around a given 'Trail'. -- Expanding can be thought of as generating the loop that, when filled, represents@@ -359,40 +368,45 @@ -- Loops result in a path with an inner and outer loop: -- -- <<diagrams/src_Diagrams_TwoD_Offset_expandLoopExample.svg#diagram=expandLoopExample&width=300>>----expandTrail' :: (OrderedField n, RealFloat n, RealFrac n)- => ExpandOpts n- -> n -- ^ Radius of offset. Only non-negative values allowed.- -- For a line this gives a loop of the offset. For a- -- loop this gives two loops, the outer counter-clockwise- -- and the inner clockwise.- -> Located (Trail V2 n)- -> Path V2 n+expandTrail' ::+ (OrderedField n, RealFloat n, RealFrac n) =>+ ExpandOpts n ->+ -- | Radius of offset. Only non-negative values allowed.+ -- For a line this gives a loop of the offset. For a+ -- loop this gives two loops, the outer counter-clockwise+ -- and the inner clockwise.+ n ->+ Located (Trail V2 n) ->+ Path V2 n expandTrail' o r t- | r < 0 = error "expandTrail' with negative radius"- -- TODO: consider just reversing the path instead of this error.+ | r < 0 = error "expandTrail' with negative radius"+ -- TODO: consider just reversing the path instead of this error. | otherwise = withTrailL (pathFromLocTrail . expandLine o r) (expandLoop o r) t expandLine :: RealFloat n => ExpandOpts n -> n -> Located (Trail' Line V2 n) -> Located (Trail V2 n) expandLine opts r (mapLoc wrapLine -> t) = caps cap r s e (f r) (f $ -r)- where- eps = opts^.expandEpsilon- offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments- f r' = joinSegments eps (fromLineJoin (opts^.expandJoin)) False (opts^.expandMiterLimit) r' ends- . offset r' $ t- ends = tail . trailPoints $ t- s = atStart t- e = atEnd t- cap = fromLineCap (opts^.expandCap)+ where+ eps = opts ^. expandEpsilon+ offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments+ f r' =+ joinSegments eps (fromLineJoin (opts ^. expandJoin)) False (opts ^. expandMiterLimit) r' ends+ . offset r'+ $ t+ ends = drop 1 . trailPoints $ t+ s = atStart t+ e = atEnd t+ cap = fromLineCap (opts ^. expandCap) expandLoop :: RealFloat n => ExpandOpts n -> n -> Located (Trail' Loop V2 n) -> Path V2 n expandLoop opts r (mapLoc wrapLoop -> t) = trailLike (f r) <> (trailLike . reverseDomain . f $ -r)- where- eps = opts^.expandEpsilon- offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments- f r' = joinSegments eps (fromLineJoin (opts^.expandJoin)) True (opts^.expandMiterLimit) r' ends- . offset r' $ t- ends = (\(a:as) -> as ++ [a]) . trailPoints $ t+ where+ eps = opts ^. expandEpsilon+ offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments+ f r' =+ joinSegments eps (fromLineJoin (opts ^. expandJoin)) True (opts ^. expandMiterLimit) r' ends+ . offset r'+ $ t+ ends = rotateL . trailPoints $ t -- | Expand a 'Trail' with the given radius and default options. See 'expandTrail''. expandTrail :: RealFloat n => n -> Located (Trail V2 n) -> Path V2 n@@ -400,9 +414,10 @@ -- | Expand a 'Path' using 'expandTrail'' on each trail in the path. expandPath' :: RealFloat n => ExpandOpts n -> n -> Path V2 n -> Path V2 n-expandPath' opts r = mconcat- . map (bindLoc (expandTrail' opts r) . (`at` origin))- . op Path+expandPath' opts r =+ mconcat+ . map (bindLoc (expandTrail' opts r) . (`at` origin))+ . op Path -- | Expand a 'Path' with the given radius and default options. See 'expandPath''. expandPath :: RealFloat n => n -> Path V2 n -> Path V2 n@@ -434,7 +449,6 @@ -- > t = mapLoc glueTrail $ fromVertices (map p2 [(0, 0), (5, 0), (10, 5), (10, 10), (0, 0)]) -- > t' = expandTrail' (def & expandJoin .~ LineJoinRound) 1 t - -- | When we expand a line (the original line runs through the center of offset -- lines at r and -r) there is some choice in what the ends will look like. -- If we are using a circle brush we should see a half circle at each end.@@ -444,21 +458,31 @@ -- caps takes the radius and the start and end points of the original line and -- the offset trails going out and coming back. The result is a new list of -- trails with the caps included.-caps :: RealFloat n => (n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n)- -> n -> Point V2 n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Located (Trail V2 n)-caps cap r s e fs bs = mapLoc glueTrail $ mconcat- [ cap r s (atStart bs) (atStart fs)- , unLoc fs- , cap r e (atEnd fs) (atEnd bs)- , reverseDomain (unLoc bs)- ] `at` atStart bs+caps ::+ RealFloat n =>+ (n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n) ->+ n ->+ Point V2 n ->+ Point V2 n ->+ Located (Trail V2 n) ->+ Located (Trail V2 n) ->+ Located (Trail V2 n)+caps cap r s e fs bs =+ mapLoc glueTrail $+ mconcat+ [ cap r s (atStart bs) (atStart fs)+ , unLoc fs+ , cap r e (atEnd fs) (atEnd bs)+ , reverseDomain (unLoc bs)+ ]+ `at` atStart bs -- | Take a LineCap style and give a function for building the cap from fromLineCap :: RealFloat n => LineCap -> n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n fromLineCap c = case c of- LineCapButt -> capCut- LineCapRound -> capArc- LineCapSquare -> capSquare+ LineCapButt -> capCut+ LineCapRound -> capArc+ LineCapSquare -> capSquare -- | Builds a cap that directly connects the ends. capCut :: RealFloat n => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n@@ -466,17 +490,18 @@ -- | Builds a cap with a square centered on the end. capSquare :: RealFloat n => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n-capSquare _r c a b = unLoc $ fromVertices [ a, a .+^ v, b .+^ v, b ]- where- v = perp (a .-. c)+capSquare _r c a b = unLoc $ fromVertices [a, a .+^ v, b .+^ v, b]+ where+ v = perp (a .-. c) -- | Builds an arc to fit with a given radius, center, start, and end points. -- A Negative r means a counter-clockwise arc capArc :: RealFloat n => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n capArc r c a b = trailLike . moveTo c $ fs- where- fs | r < 0 = scale (-r) $ arcCW (dirBetween c a) (dirBetween c b)- | otherwise = scale r $ arcCCW (dirBetween c a) (dirBetween c b)+ where+ fs+ | r < 0 = scale (-r) $ arcCW (dirBetween c a) (dirBetween c b)+ | otherwise = scale r $ arcCCW (dirBetween c a) (dirBetween c b) -- | Join together a list of located trails with the given join style. The -- style is given as a function to compute the join given the local information@@ -486,34 +511,36 @@ -- Note: this is not a general purpose join and assumes that we are joining an -- offset trail. For instance, a fixed radius arc will not fit between arbitrary -- trails without trimming or extending.-joinSegments :: RealFloat n- => n- -> (n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n)- -> Bool- -> n- -> n- -> [Point V2 n]- -> [Located (Trail V2 n)]- -> Located (Trail V2 n)+joinSegments ::+ RealFloat n =>+ n ->+ (n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n) ->+ Bool ->+ n ->+ n ->+ [Point V2 n] ->+ [Located (Trail V2 n)] ->+ Located (Trail V2 n) joinSegments _ _ _ _ _ _ [] = mempty `at` origin joinSegments _ _ _ _ _ [] _ = mempty `at` origin-joinSegments epsilon j isLoop ml r es ts@(t:_) = t'- where- t' | isLoop = mapLoc (glueTrail . (<> f (take (length ts * 2 - 1) $ ss es (ts ++ [t])))) t- | otherwise = mapLoc (<> f (ss es ts)) t- ss es' ts' = concat [[test a b $ j ml r e a b, Just $ unLoc b] | (e,(a,b)) <- zip es' . (zip <*> tail) $ ts']- test a b tj- | atStart b `distance` atEnd a > epsilon = Just tj- | otherwise = Nothing- f = mconcat . catMaybes+joinSegments epsilon j isLoop ml r es ts@(t : _) = t'+ where+ t'+ | isLoop = mapLoc (glueTrail . (<> f (take (length ts * 2 - 1) $ ss es (ts ++ [t])))) t+ | otherwise = mapLoc (<> f (ss es ts)) t+ ss es' ts' = concat [[test a b $ j ml r e a b, Just $ unLoc b] | (e, (a, b)) <- zip es' . (zip <*> drop 1) $ ts']+ test a b tj+ | atStart b `distance` atEnd a > epsilon = Just tj+ | otherwise = Nothing+ f = mconcat . catMaybes -- | Take a join style and give the join function to be used by joinSegments.-fromLineJoin- :: RealFloat n => LineJoin -> n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n+fromLineJoin ::+ RealFloat n => LineJoin -> n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n fromLineJoin j = case j of- LineJoinMiter -> joinSegmentIntersect- LineJoinRound -> joinSegmentArc- LineJoinBevel -> joinSegmentClip+ LineJoinMiter -> joinSegmentIntersect+ LineJoinRound -> joinSegmentArc+ LineJoinBevel -> joinSegmentClip -- TODO: The joinSegmentCut option is not in our standard line joins. I don't know -- how useful it is graphically, I mostly had it as it was useful for debugging@@ -529,38 +556,44 @@ -- | Join by directly connecting the end points. On an inside corner this -- creates negative space for even-odd fill. Here is where we would want to -- use an arc or something else in the future.-joinSegmentClip :: RealFloat n- => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n+joinSegmentClip ::+ RealFloat n =>+ n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n joinSegmentClip _ _ _ a b = fromSegments [straight $ atStart b .-. atEnd a] -- | Join with a radius arc. On an inside corner this will loop around the interior -- of the offset trail. With a winding fill this will not be visible.-joinSegmentArc :: RealFloat n- => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n+joinSegmentArc ::+ RealFloat n =>+ n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n joinSegmentArc _ r e a b = capArc r e (atEnd a) (atStart b) -- | Join to the intersection of the incoming trails projected tangent to their ends. -- If the intersection is beyond the miter limit times the radius, stop at the limit.-joinSegmentIntersect- :: RealFloat n => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n+joinSegmentIntersect ::+ RealFloat n => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n joinSegmentIntersect miterLimit r e a b =- if cross < 0.000001- then clip- else case traceP pa va t of- -- clip join when we excede the miter limit. We could instead- -- Join at exactly the miter limit, but standard behavior seems- -- to be clipping.- Nothing -> clip- Just p- -- If trace gave us garbage...- | p `distance` pb > abs (miterLimit * r) -> clip- | otherwise -> unLoc $ fromVertices [ pa, p, pb ]- where- t = straight (miter vb) `at` pb- va = unitPerp (pa .-. e)- vb = negated $ unitPerp (pb .-. e)- pa = atEnd a- pb = atStart b- miter v = abs (miterLimit * r) *^ v- clip = joinSegmentClip miterLimit r e a b- cross = let (xa,ya) = unr2 va; (xb,yb) = unr2 vb in abs (xa * yb - xb * ya)+ if cross < 0.000001+ then clip+ else case traceP pa va t of+ -- clip join when we excede the miter limit. We could instead+ -- Join at exactly the miter limit, but standard behavior seems+ -- to be clipping.+ Nothing -> clip+ Just p+ -- If trace gave us garbage...+ | p `distance` pb > abs (miterLimit * r) -> clip+ | otherwise -> unLoc $ fromVertices [pa, p, pb]+ where+ t = straight (miter vb) `at` pb+ va = unitPerp (pa .-. e)+ vb = negated $ unitPerp (pb .-. e)+ pa = atEnd a+ pb = atStart b+ miter v = abs (miterLimit * r) *^ v+ clip = joinSegmentClip miterLimit r e a b+ cross = let (xa, ya) = unr2 va; (xb, yb) = unr2 vb in abs (xa * yb - xb * ya)++rotateL :: [a] -> [a]+rotateL [] = []+rotateL (a : as) = as ++ [a]
src/Diagrams/TwoD/Path.hs view
@@ -1,20 +1,17 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}-+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ -- | -- Module : Diagrams.TwoD.Path -- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE)@@ -25,69 +22,81 @@ -- create a 2D diagram, and (eventually) perform operations such as -- intersection and union. They also have a trace, whereas paths in -- higher dimensions do not.-----------------------------------------------------------------------------------module Diagrams.TwoD.Path- ( -- * Constructing path-based diagrams-- stroke, stroke'- , strokePath, strokeP, strokePath', strokeP'- , strokeTrail, strokeT, strokeTrail', strokeT'- , strokeLine, strokeLoop- , strokeLocTrail, strokeLocT, strokeLocLine, strokeLocLoop-- -- ** Stroke options-- , FillRule(..)- , getFillRule, fillRule, _fillRule- , StrokeOpts(..), vertexNames, queryFillRule-- -- ** Inside/outside testing-- , Crossings (..)- , isInsideWinding- , isInsideEvenOdd-- -- * Clipping-- , Clip(..), _Clip, _clip- , clipBy, clipTo, clipped-- -- * Intersections+module Diagrams.TwoD.Path (+ -- * Constructing path-based diagrams+ stroke,+ stroke',+ strokePath,+ strokeP,+ strokePath',+ strokeP',+ strokeTrail,+ strokeT,+ strokeTrail',+ strokeT',+ strokeLine,+ strokeLoop,+ strokeLocTrail,+ strokeLocT,+ strokeLocLine,+ strokeLocLoop, - , intersectPoints, intersectPoints'- , intersectPointsP, intersectPointsP'- , intersectPointsT, intersectPointsT'- ) where+ -- ** Stroke options+ FillRule (..),+ getFillRule,+ fillRule,+ _fillRule,+ StrokeOpts (..),+ vertexNames,+ queryFillRule, -import Control.Applicative (liftA2)-import Control.Lens hiding (at, transform)-import qualified Data.Foldable as F-import Data.Semigroup-import Data.Typeable+ -- ** Inside/outside testing+ Crossings (..),+ isInsideWinding,+ isInsideEvenOdd, -import Data.Default+ -- * Clipping+ Clip (..),+ _Clip,+ _clip,+ clipBy,+ clipTo,+ clipped, -import Diagrams.Angle-import Diagrams.Combinators (withEnvelope, withTrace)-import Diagrams.Core-import Diagrams.Core.Trace-import Diagrams.Located (Located, mapLoc, unLoc)-import Diagrams.Parametric-import Diagrams.Path-import Diagrams.Query-import Diagrams.Segment-import Diagrams.Solve.Polynomial-import Diagrams.Trail-import Diagrams.TrailLike-import Diagrams.TwoD.Segment-import Diagrams.TwoD.Types-import Diagrams.TwoD.Vector-import Diagrams.Util (tau)+ -- * Intersections+ intersectPoints,+ intersectPoints',+ intersectPointsP,+ intersectPointsP',+ intersectPointsT,+ intersectPointsT',+) where -import Linear.Affine-import Linear.Vector+import Control.Lens hiding (at, transform)+import Data.Default+import qualified Data.Foldable as F+import Data.Semigroup+import Data.Typeable+import Diagrams.Angle+import Diagrams.Combinators (withEnvelope, withTrace)+import Diagrams.Core+import Diagrams.Core.Trace+import Diagrams.Located (Located, mapLoc, unLoc)+import Diagrams.Parametric+import Diagrams.Path+import Diagrams.Query+import Diagrams.Segment+import Diagrams.Solve.Polynomial+import Diagrams.Trail+import Diagrams.TrailLike+import Diagrams.TwoD.Segment+import Diagrams.TwoD.Types+import Diagrams.TwoD.Vector+import Diagrams.Util (tau)+import Linear.Affine+import Linear.Vector+import Prelude.Compat+import Prelude () ------------------------------------------------------------ -- Trail and path traces ---------------------------------@@ -98,11 +107,12 @@ -- XXX can the efficiency of this be improved? See the comment in -- Diagrams.Path on the Enveloped instance for Trail. instance RealFloat n => Traced (Trail V2 n) where- getTrace = withLine $- foldr+ getTrace =+ withLine+ $ foldr (\seg bds -> moveOriginBy (negated . atEnd $ seg) bds <> getTrace seg) mempty- . lineSegments+ . lineSegments instance RealFloat n => Traced (Path V2 n) where getTrace = F.foldMap getTrace . op Path@@ -115,14 +125,16 @@ -- points lie in the interior of a (possibly self-intersecting) -- path. data FillRule- = Winding -- ^ Interior points are those with a nonzero- -- /winding/ /number/. See- -- <http://en.wikipedia.org/wiki/Nonzero-rule>.- | EvenOdd -- ^ Interior points are those where a ray- -- extended infinitely in a particular direction crosses- -- the path an odd number of times. See- -- <http://en.wikipedia.org/wiki/Even-odd_rule>.- deriving (Show, Typeable, Eq, Ord)+ = -- | Interior points are those with a nonzero+ -- /winding/ /number/. See+ -- <http://en.wikipedia.org/wiki/Nonzero-rule>.+ Winding+ | -- | Interior points are those where a ray+ -- extended infinitely in a particular direction crosses+ -- the path an odd number of times. See+ -- <http://en.wikipedia.org/wiki/Even-odd_rule>.+ EvenOdd+ deriving (Show, Eq, Ord) instance AttributeClass FillRule instance Semigroup FillRule where@@ -136,11 +148,9 @@ -- records can be created using @'with' { ... }@ notation. data StrokeOpts a = StrokeOpts- { _vertexNames :: [[a]]-- , _queryFillRule :: FillRule-- }+ { _vertexNames :: [[a]]+ , _queryFillRule :: FillRule+ } makeLensesWith (generateSignatures .~ False $ lensRules) ''StrokeOpts @@ -153,7 +163,6 @@ -- so on. -- -- The default value is the empty list.- vertexNames :: Lens (StrokeOpts a) (StrokeOpts a') [[a]] [[a']] -- | The fill rule used for determining which points are inside the path.@@ -163,10 +172,11 @@ queryFillRule :: Lens' (StrokeOpts a) FillRule instance Default (StrokeOpts a) where- def = StrokeOpts- { _vertexNames = []- , _queryFillRule = def- }+ def =+ StrokeOpts+ { _vertexNames = []+ , _queryFillRule = def+ } -- | Convert a 'ToPath' object into a diagram. The resulting diagram has the -- names 0, 1, ... assigned to each of the path's vertices.@@ -180,8 +190,9 @@ -- 'stroke' :: 'Located' ('Trail'' 'Loop' 'V2' 'Double') -> 'Diagram' b -- 'stroke' :: 'Located' ('Trail'' 'Line' 'V2' 'Double') -> 'Diagram' b -- @-stroke :: (InSpace V2 n t, ToPath t, TypeableFloat n, Renderable (Path V2 n) b)- => t -> QDiagram b V2 n Any+stroke ::+ (InSpace V2 n t, ToPath t, TypeableFloat n, Renderable (Path V2 n) b) =>+ t -> QDiagram b V2 n Any stroke = strokeP . toPath -- | A variant of 'stroke' that takes an extra record of options to@@ -191,101 +202,120 @@ -- -- 'StrokeOpts' is an instance of 'Default', so @stroke' ('with' & -- ... )@ syntax may be used.-stroke' :: (InSpace V2 n t, ToPath t, TypeableFloat n, Renderable (Path V2 n) b, IsName a)- => StrokeOpts a -> t -> QDiagram b V2 n Any+stroke' ::+ (InSpace V2 n t, ToPath t, TypeableFloat n, Renderable (Path V2 n) b, IsName a) =>+ StrokeOpts a -> t -> QDiagram b V2 n Any stroke' opts = strokeP' opts . toPath -- | 'stroke' specialised to 'Path'.-strokeP :: (TypeableFloat n, Renderable (Path V2 n) b)- => Path V2 n -> QDiagram b V2 n Any+strokeP ::+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ Path V2 n -> QDiagram b V2 n Any strokeP = strokeP' (def :: StrokeOpts ()) -- | 'stroke' specialised to 'Path'.-strokePath :: (TypeableFloat n, Renderable (Path V2 n) b)- => Path V2 n -> QDiagram b V2 n Any+strokePath ::+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ Path V2 n -> QDiagram b V2 n Any strokePath = strokeP -instance (TypeableFloat n, Renderable (Path V2 n) b)- => TrailLike (QDiagram b V2 n Any) where+instance+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ TrailLike (QDiagram b V2 n Any)+ where trailLike = strokeP . trailLike -- | 'stroke'' specialised to 'Path'.-strokeP' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a)- => StrokeOpts a -> Path V2 n -> QDiagram b V2 n Any+strokeP' ::+ (TypeableFloat n, Renderable (Path V2 n) b, IsName a) =>+ StrokeOpts a -> Path V2 n -> QDiagram b V2 n Any strokeP' opts path | null (pLines ^. _Wrapped') = mkP pLoops | null (pLoops ^. _Wrapped') = mkP pLines- | otherwise = mkP pLines <> mkP pLoops- where- (pLines,pLoops) = partitionPath (isLine . unLoc) path- mkP p- = mkQD (Prim p)- (getEnvelope p)- (getTrace p)- (fromNames . concat $- zipWith zip (opts^.vertexNames) ((map . map) subPoint (pathVertices p))- )- (Query $ Any . (runFillRule (opts^.queryFillRule)) p)+ | otherwise = mkP pLines <> mkP pLoops+ where+ (pLines, pLoops) = partitionPath (isLine . unLoc) path+ mkP p =+ mkQD+ (Prim p)+ (getEnvelope p)+ (getTrace p)+ ( fromNames+ . concat+ $ zipWith zip (opts ^. vertexNames) ((map . map) subPoint (pathVertices p))+ )+ (Query $ Any . (runFillRule (opts ^. queryFillRule)) p) -- | 'stroke'' specialised to 'Path'.-strokePath' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a)- => StrokeOpts a -> Path V2 n -> QDiagram b V2 n Any+strokePath' ::+ (TypeableFloat n, Renderable (Path V2 n) b, IsName a) =>+ StrokeOpts a -> Path V2 n -> QDiagram b V2 n Any strokePath' = strokeP' -- | 'stroke' specialised to 'Trail'.-strokeTrail :: (TypeableFloat n, Renderable (Path V2 n) b)- => Trail V2 n -> QDiagram b V2 n Any+strokeTrail ::+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ Trail V2 n -> QDiagram b V2 n Any strokeTrail = stroke . pathFromTrail -- | 'stroke' specialised to 'Trail'.-strokeT :: (TypeableFloat n, Renderable (Path V2 n) b)- => Trail V2 n -> QDiagram b V2 n Any+strokeT ::+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ Trail V2 n -> QDiagram b V2 n Any strokeT = strokeTrail -- | A composition of 'stroke'' and 'pathFromTrail' for conveniently -- converting a trail directly into a diagram.-strokeTrail' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a)- => StrokeOpts a -> Trail V2 n -> QDiagram b V2 n Any+strokeTrail' ::+ (TypeableFloat n, Renderable (Path V2 n) b, IsName a) =>+ StrokeOpts a -> Trail V2 n -> QDiagram b V2 n Any strokeTrail' opts = stroke' opts . pathFromTrail -- | Deprecated synonym for 'strokeTrail''.-strokeT' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a)- => StrokeOpts a -> Trail V2 n -> QDiagram b V2 n Any+strokeT' ::+ (TypeableFloat n, Renderable (Path V2 n) b, IsName a) =>+ StrokeOpts a -> Trail V2 n -> QDiagram b V2 n Any strokeT' = strokeTrail' -- | A composition of 'strokeT' and 'wrapLine' for conveniently -- converting a line directly into a diagram.-strokeLine :: (TypeableFloat n, Renderable (Path V2 n) b)- => Trail' Line V2 n -> QDiagram b V2 n Any+strokeLine ::+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ Trail' Line V2 n -> QDiagram b V2 n Any strokeLine = strokeT . wrapLine -- | A composition of 'strokeT' and 'wrapLoop' for conveniently -- converting a loop directly into a diagram.-strokeLoop :: (TypeableFloat n, Renderable (Path V2 n) b)- => Trail' Loop V2 n -> QDiagram b V2 n Any+strokeLoop ::+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ Trail' Loop V2 n -> QDiagram b V2 n Any strokeLoop = strokeT . wrapLoop -- | A convenience function for converting a @Located Trail@ directly -- into a diagram; @strokeLocTrail = stroke . trailLike@.-strokeLocTrail :: (TypeableFloat n, Renderable (Path V2 n) b)- => Located (Trail V2 n) -> QDiagram b V2 n Any+strokeLocTrail ::+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ Located (Trail V2 n) -> QDiagram b V2 n Any strokeLocTrail = strokeP . trailLike -- | Deprecated synonym for 'strokeLocTrail'.-strokeLocT :: (TypeableFloat n, Renderable (Path V2 n) b)- => Located (Trail V2 n) -> QDiagram b V2 n Any+strokeLocT ::+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ Located (Trail V2 n) -> QDiagram b V2 n Any strokeLocT = strokeLocTrail -- | A convenience function for converting a @Located@ line directly -- into a diagram; @strokeLocLine = stroke . trailLike . mapLoc wrapLine@.-strokeLocLine :: (TypeableFloat n, Renderable (Path V2 n) b)- => Located (Trail' Line V2 n) -> QDiagram b V2 n Any+strokeLocLine ::+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ Located (Trail' Line V2 n) -> QDiagram b V2 n Any strokeLocLine = strokeP . trailLike . mapLoc wrapLine -- | A convenience function for converting a @Located@ loop directly -- into a diagram; @strokeLocLoop = stroke . trailLike . mapLoc wrapLoop@.-strokeLocLoop :: (TypeableFloat n, Renderable (Path V2 n) b)- => Located (Trail' Loop V2 n) -> QDiagram b V2 n Any+strokeLocLoop ::+ (TypeableFloat n, Renderable (Path V2 n) b) =>+ Located (Trail' Loop V2 n) -> QDiagram b V2 n Any strokeLocLoop = strokeP . trailLike . mapLoc wrapLoop ------------------------------------------------------------@@ -336,7 +366,7 @@ Crossings a <> Crossings b = Crossings (a + b) instance Monoid Crossings where- mempty = Crossings 0+ mempty = Crossings 0 mappend = (<>) instance RealFloat n => HasQuery (Located (Trail V2 n)) Crossings where@@ -379,41 +409,49 @@ -- | Compute the sum of signed crossings of a trail starting from the -- given point in the positive x direction. trailCrossings :: RealFloat n => Point V2 n -> Located (Trail V2 n) -> Crossings-- -- non-loop trails have no inside or outside, so don't contribute crossings+-- 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)) tr- = F.foldMap test $ fixTrail tr- where- test (FLinear a@(unp2 -> (_,ay)) b@(unp2 -> (_,by)))- | ay <= y && by > y && isLeft a b > 0 = 1- | by <= y && ay > y && isLeft a b < 0 = -1- | otherwise = 0-- test c@(FCubic (P x1@(V2 _ x1y))- (P c1@(V2 _ c1y))- (P c2@(V2 _ c2y))- (P x2@(V2 _ x2y))- ) =- sum . map testT $ ts- where ts = filter (liftA2 (&&) (>=0) (<=1))- $ cubForm (- x1y + 3*c1y - 3*c2y + x2y)- ( 3*x1y - 6*c1y + 3*c2y)- (-3*x1y + 3*c1y)- (x1y - y)- testT t = let (unp2 -> (px,_)) = c `atParam` t- in if px > x then signFromDerivAt t else 0- signFromDerivAt t =- let v = (3*t*t) *^ ((-1)*^x1 ^+^ 3*^c1 ^-^ 3*^c2 ^+^ x2)- ^+^ (2*t) *^ (3*^x1 ^-^ 6*^c1 ^+^ 3*^c2)- ^+^ ((-3)*^x1 ^+^ 3*^c1)- ang = v ^. _theta . rad- in case () of _ | 0 < ang && ang < tau/2 && t < 1 -> 1- | -tau/2 < ang && ang < 0 && t > 0 -> -1- | otherwise -> 0+trailCrossings p@(unp2 -> (x, y)) tr =+ F.foldMap test $ fixTrail tr+ where+ test (FLinear a@(unp2 -> (_, ay)) b@(unp2 -> (_, by)))+ | ay <= y && by > y && isLeft a b > 0 = 1+ | by <= y && ay > y && isLeft a b < 0 = -1+ | otherwise = 0+ test+ c@( FCubic+ (P x1@(V2 _ x1y))+ (P c1@(V2 _ c1y))+ (P c2@(V2 _ c2y))+ (P x2@(V2 _ x2y))+ ) =+ sum . map testT $ ts+ where+ ts =+ filter (liftA2 (&&) (>= 0) (<= 1))+ $ cubForm+ (-x1y + 3 * c1y - 3 * c2y + x2y)+ (3 * x1y - 6 * c1y + 3 * c2y)+ (-3 * x1y + 3 * c1y)+ (x1y - y)+ testT t =+ let (unp2 -> (px, _)) = c `atParam` t+ in if px > x then signFromDerivAt t else 0+ signFromDerivAt t =+ let v =+ (3 * t * t)+ *^ ((-1) *^ x1 ^+^ 3 *^ c1 ^-^ 3 *^ c2 ^+^ x2)+ ^+^ (2 * t)+ *^ (3 *^ x1 ^-^ 6 *^ c1 ^+^ 3 *^ c2)+ ^+^ ((-3) *^ x1 ^+^ 3 *^ c1)+ ang = v ^. _theta . rad+ in case () of+ _+ | 0 < ang && ang < tau / 2 && t < 1 -> 1+ | -tau / 2 < ang && ang < 0 && t > 0 -> -1+ | otherwise -> 0 - isLeft a b = cross2 (b .-. a) (p .-. a)+ isLeft a b = cross2 (b .-. a) (p .-. a) ------------------------------------------------------------ -- Clipping ----------------------------------------------@@ -425,7 +463,7 @@ -- The clipping region is the intersection of all the applied -- clipping paths. newtype Clip n = Clip [Path V2 n]- deriving (Typeable, Semigroup)+ deriving (Semigroup) makeWrapped ''Clip @@ -437,7 +475,7 @@ type instance V (Clip n) = V2 type instance N (Clip n) = n -instance (OrderedField n) => Transformable (Clip n) where+instance OrderedField n => Transformable (Clip n) where transform t (Clip ps) = Clip (transform t ps) -- | A point inside a clip if the point is in 'All' invididual clipping@@ -460,36 +498,40 @@ -- -- * The envelope of the diagram is unaffected. clipBy :: (HasStyle a, V a ~ V2, N a ~ n, TypeableFloat n) => Path V2 n -> a -> a-clipBy = applyTAttr . Clip . (:[])+clipBy = applyTAttr . Clip . (: []) -- | Clip a diagram to the given path setting its envelope to the -- pointwise minimum of the envelopes of the diagram and path. The -- trace consists of those parts of the original diagram's trace -- which fall within the clipping path, or parts of the path's trace -- within the original diagram.-clipTo :: TypeableFloat n- => Path V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any+clipTo ::+ TypeableFloat n =>+ Path V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d- where- envP = appEnvelope . getEnvelope $ p- envD = appEnvelope . getEnvelope $ d- toEnvelope = case (envP, envD) of- (Just eP, Just eD) -> setEnvelope . mkEnvelope $ \v -> min (eP v) (eD v)- (_, _) -> id- intersectionTrace = Trace traceIntersections- traceIntersections pt v =- -- on boundary of d, inside p- onSortedList (filter pInside) (appTrace (getTrace d) pt v) <>- -- or on boundary of p, inside d- onSortedList (filter dInside) (appTrace (getTrace p) pt v) where- newPt dist = pt .+^ v ^* dist- pInside dDist = runFillRule Winding p (newPt dDist)- dInside pDist = getAny . sample d $ newPt pDist+ where+ envP = appEnvelope . getEnvelope $ p+ envD = appEnvelope . getEnvelope $ d+ toEnvelope = case (envP, envD) of+ (Just eP, Just eD) -> setEnvelope . mkEnvelope $ \v -> min (eP v) (eD v)+ (_, _) -> id+ intersectionTrace = Trace traceIntersections+ traceIntersections pt v =+ -- on boundary of d, inside p+ onSortedList (filter pInside) (appTrace (getTrace d) pt v)+ <>+ -- or on boundary of p, inside d+ onSortedList (filter dInside) (appTrace (getTrace p) pt v)+ where+ newPt dist = pt .+^ v ^* dist+ pInside dDist = runFillRule Winding p (newPt dDist)+ dInside pDist = getAny . sample d $ newPt pDist -- | Clip a diagram to the clip path taking the envelope and trace of the clip -- path.-clipped :: TypeableFloat n- => Path V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any+clipped ::+ TypeableFloat n =>+ Path V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any clipped p = withTrace p . withEnvelope p . clipBy p ------------------------------------------------------------@@ -497,14 +539,16 @@ ------------------------------------------------------------ -- | Find the intersect points of two objects that can be converted to a path.-intersectPoints :: (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n)- => t -> s -> [P2 n]+intersectPoints ::+ (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) =>+ t -> s -> [P2 n] intersectPoints = intersectPoints' 1e-8 -- | Find the intersect points of two objects that can be converted to a path -- within the given tolerance.-intersectPoints' :: (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n)- => n -> t -> s -> [P2 n]+intersectPoints' ::+ (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) =>+ n -> t -> s -> [P2 n] intersectPoints' eps t s = intersectPointsP' eps (toPath t) (toPath s) -- | Compute the intersect points between two paths.
src/Diagrams/TwoD/Points.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-}------------------------------------------------------------------------------+{-# LANGUAGE TypeFamilies #-}+ -- | -- Module : Diagrams.TwoD.Points -- Copyright : (c) 2014 diagrams-lib team (see LICENSE)@@ -7,54 +8,49 @@ -- Maintainer : diagrams-discuss@googlegroups.com -- -- Special functions for points in R2.-----------------------------------------------------------------------------------{-# LANGUAGE TypeFamilies #-}- module Diagrams.TwoD.Points where -import Data.List-+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE import Diagrams.Core-import Diagrams.TwoD.Vector import Diagrams.TwoD.Types (P2)+import Diagrams.TwoD.Vector import Linear.Affine -- | Find the convex hull of a list of points using Andrew's monotone chain -- algorithm O(n log n).--- +-- -- Returns clockwise list of points starting from the left-most point. convexHull2D :: OrderedField n => [P2 n] -> [P2 n]-convexHull2D ps = init upper ++ reverse (tail lower)- where- (upper, lower) = sortedConvexHull (sort ps)+convexHull2D [] = []+convexHull2D (p : ps) = NE.init upper ++ reverse (NE.tail lower)+ where+ (upper, lower) = sortedConvexHull (NE.sort (p :| ps)) --- | Find the convex hull of a set of points already sorted in the x direction. --- The first list of the tuple is the upper hull going clockwise from --- left-most to right-most point. The second is the lower hull from +-- | Find the convex hull of a set of points already sorted in the x direction.+-- The first list of the tuple is the upper hull going clockwise from+-- left-most to right-most point. The second is the lower hull from -- right-most to left-most in the anti-clockwise direction.-sortedConvexHull :: OrderedField n => [P2 n] -> ([P2 n], [P2 n])+sortedConvexHull :: OrderedField n => NonEmpty (P2 n) -> (NonEmpty (P2 n), NonEmpty (P2 n)) sortedConvexHull ps = (chain True ps, chain False ps) where- chain upper (p1_:p2_:rest_) =- case go (p2_ .-. p1_) p2_ rest_ of- Right l -> p1_:l- Left l -> chain upper (p1_:l)+ chain upper (p1_ :| p2_ : rest_) =+ case go (p2_ .-. p1_) p2_ rest_ of+ Right l -> p1_ :| l+ Left l -> chain upper (p1_ :| l)+ where+ test = if upper then (> 0) else (< 0)+ -- find the convex hull by comparing the angles of the vectors with+ -- the cross product and backtracking if necessary+ go dir p1 l@(p2 : rest)+ -- backtrack if the direction is outward+ | test $ dir `cross2` dir' = Left l+ | otherwise =+ case go dir' p2 rest of+ Left m -> go dir p1 m+ Right m -> Right (p1 : m) where- test = if upper then (>0) else (<0)- -- find the convex hull by comparing the angles of the vectors with- -- the cross product and backtracking if necessary- go dir p1 l@(p2:rest)- -- backtrack if the direction is outward- | test $ dir `cross2` dir' = Left l- | otherwise =- case go dir' p2 rest of- Left m -> go dir p1 m- Right m -> Right (p1:m)- where- dir' = p2 .-. p1- go _ p1 p = Right (p1:p)-- chain _ l = l+ dir' = p2 .-. p1+ go _ p1 p = Right (p1 : p)+ chain _ l = l
src/Diagrams/TwoD/Polygons.hs view
@@ -1,12 +1,11 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------ -- | -- Module : Diagrams.TwoD.Polygons -- Copyright : (c) 2011 diagrams-lib team (see LICENSE)@@ -15,133 +14,147 @@ -- -- This module defines a general API for creating various types of -- polygons.-----------------------------------------------------------------------------------module Diagrams.TwoD.Polygons(- -- * Polygons- PolyType(..)- , PolyOrientation(..)- , PolygonOpts(..), polyType, polyOrient, polyCenter-- , polygon- , polyTrail-- -- ** Generating polygon vertices-- , polyPolarTrail- , polySidesTrail- , polyRegularTrail-- , orient+module Diagrams.TwoD.Polygons (+ -- * Polygons+ PolyType (..),+ PolyOrientation (..),+ PolygonOpts (..),+ polyType,+ polyOrient,+ polyCenter,+ polygon,+ polyTrail, - -- * Star polygons- , StarOpts(..)- , star+ -- ** Generating polygon vertices+ polyPolarTrail,+ polySidesTrail,+ polyRegularTrail,+ orient, - -- ** Function graphs- -- $graphs- , GraphPart(..)- , orbits, mkGraph+ -- * Star polygons+ StarOpts (..),+ star, - ) where+ -- ** Function graphs+ -- $graphs+ GraphPart (..),+ orbits,+ mkGraph,+) where -import Control.Lens (Lens', generateSignatures, lensRules,- makeLensesWith, view, (.~), (^.))-import Control.Monad (forM, liftM)-import Control.Monad.ST (ST, runST)-import Data.Array.ST (STUArray, newArray, readArray,- writeArray)-import Data.Default-import Data.List (maximumBy, minimumBy)-import Data.Maybe (catMaybes)-import Data.Ord (comparing)+import Control.Lens (+ Lens',+ generateSignatures,+ lensRules,+ makeLensesWith,+ view,+ (.~),+ (^.),+ )+import Control.Monad (forM, liftM)+import Control.Monad.ST (ST, runST)+import Data.Array.ST (+ STUArray,+ newArray,+ readArray,+ writeArray,+ )+import Data.Default+import Data.List (maximumBy, minimumBy)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (catMaybes)+import Data.Ord (comparing) -import Diagrams.Angle-import Diagrams.Core-import Diagrams.Located-import Diagrams.Path-import Diagrams.Points (centroid)-import Diagrams.Trail-import Diagrams.TrailLike-import Diagrams.TwoD.Types-import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y)-import Diagrams.Util (tau, ( # ))+import Diagrams.Angle+import Diagrams.Core+import Diagrams.Located+import Diagrams.Path+import Diagrams.Points (centroid)+import Diagrams.Trail+import Diagrams.TrailLike+import Diagrams.TwoD.Types+import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y)+import Diagrams.Util (tau, (#)) -import Linear.Affine-import Linear.Metric-import Linear.Vector+import Linear.Affine+import Linear.Metric+import Linear.Vector -- | Method used to determine the vertices of a polygon.-data PolyType n = PolyPolar [Angle n] [n]- -- ^ A \"polar\" polygon.- --- -- * The first argument is a list of /central/- -- /angles/ from each vertex to the next.- --- -- * The second argument is a list of /radii/ from- -- the origin to each successive vertex.- --- -- To construct an /n/-gon, use a list of /n-1/- -- angles and /n/ radii. Extra angles or radii- -- are ignored.- --- -- Cyclic polygons (with all vertices lying on a- -- circle) can be constructed using a second- -- argument of @(repeat r)@.-- | PolySides [Angle n] [n]- -- ^ A polygon determined by the distance between- -- successive vertices and the external angles formed- -- by each three successive vertices. In other- -- words, a polygon specified by \"turtle- -- graphics\": go straight ahead x1 units; turn by- -- external angle a1; go straight ahead x2 units; turn by- -- external angle a2; etc. The polygon will be centered- -- at the /centroid/ of its vertices.- --- -- * The first argument is a list of /vertex/- -- /angles/, giving the external angle at each vertex- -- from the previous vertex to the next. The- -- first angle in the list is the external angle at- -- the /second/ vertex; the first edge always starts- -- out heading in the positive y direction from- -- the first vertex.- --- -- * The second argument is a list of distances- -- between successive vertices.- --- -- To construct an /n/-gon, use a list of /n-2/- -- angles and /n-1/ edge lengths. Extra angles or- -- lengths are ignored.-- | PolyRegular Int n- -- ^ A regular polygon with the given number of- -- sides (first argument) and the given radius- -- (second argument).+data PolyType n+ = -- | A \"polar\" polygon.+ --+ -- * The first argument is a list of /central/+ -- /angles/ from each vertex to the next.+ --+ -- * The second argument is a list of /radii/ from+ -- the origin to each successive vertex.+ --+ -- To construct an /n/-gon, use a list of /n-1/+ -- angles and /n/ radii. Extra angles or radii+ -- are ignored.+ --+ -- Cyclic polygons (with all vertices lying on a+ -- circle) can be constructed using a second+ -- argument of @(repeat r)@.+ PolyPolar [Angle n] [n]+ | -- | A polygon determined by the distance between+ -- successive vertices and the external angles formed+ -- by each three successive vertices. In other+ -- words, a polygon specified by \"turtle+ -- graphics\": go straight ahead x1 units; turn by+ -- external angle a1; go straight ahead x2 units; turn by+ -- external angle a2; etc. The polygon will be centered+ -- at the /centroid/ of its vertices.+ --+ -- * The first argument is a list of /vertex/+ -- /angles/, giving the external angle at each vertex+ -- from the previous vertex to the next. The+ -- first angle in the list is the external angle at+ -- the /second/ vertex; the first edge always starts+ -- out heading in the positive y direction from+ -- the first vertex.+ --+ -- * The second argument is a list of distances+ -- between successive vertices.+ --+ -- To construct an /n/-gon, use a list of /n-2/+ -- angles and /n-1/ edge lengths. Extra angles or+ -- lengths are ignored.+ PolySides [Angle n] [n]+ | -- | A regular polygon with the given number of+ -- sides (first argument) and the given radius+ -- (second argument).+ PolyRegular Int n -- | Determine how a polygon should be oriented.-data PolyOrientation n = NoOrient -- ^ No special orientation; the first- -- vertex will be at (1,0).- | OrientH -- ^ Orient /horizontally/, so the- -- bottommost edge is parallel to- -- the x-axis.- -- This is the default.- | OrientV -- ^ Orient /vertically/, so the- -- leftmost edge is parallel to the- -- y-axis.- | OrientTo (V2 n) -- ^ Orient so some edge is- -- /facing/ /in/ /the/ /direction/- -- /of/, that is, perpendicular- -- to, the given vector.- deriving (Eq, Ord, Show, Read)+data PolyOrientation n+ = -- | No special orientation; the first+ -- vertex will be at (1,0).+ NoOrient+ | -- | Orient /horizontally/, so the+ -- bottommost edge is parallel to+ -- the x-axis.+ -- This is the default.+ OrientH+ | -- | Orient /vertically/, so the+ -- leftmost edge is parallel to the+ -- y-axis.+ OrientV+ | -- | Orient so some edge is+ -- /facing/ /in/ /the/ /direction/+ -- /of/, that is, perpendicular+ -- to, the given vector.+ OrientTo (V2 n)+ deriving (Eq, Ord, Show, Read) -- | Options for specifying a polygon. data PolygonOpts n = PolygonOpts- { _polyType :: PolyType n- , _polyOrient :: PolyOrientation n- , _polyCenter :: Point V2 n- }+ { _polyType :: PolyType n+ , _polyOrient :: PolyOrientation n+ , _polyCenter :: Point V2 n+ } makeLensesWith (generateSignatures .~ False $ lensRules) ''PolygonOpts @@ -159,21 +172,21 @@ -- | The default polygon is a regular pentagon of radius 1, centered -- at the origin, aligned to the x-axis. instance Num n => Default (PolygonOpts n) where- def = PolygonOpts (PolyRegular 5 1) OrientH origin+ def = PolygonOpts (PolyRegular 5 1) OrientH origin -- | Generate a polygon. See 'PolygonOpts' for more information. polyTrail :: OrderedField n => PolygonOpts n -> Located (Trail V2 n) polyTrail po = transform ori tr- where- tr = case po^.polyType of- PolyPolar ans szs -> polyPolarTrail ans szs- PolySides ans szs -> polySidesTrail ans szs- PolyRegular n r -> polyRegularTrail n r- ori = case po^.polyOrient of- OrientH -> orient unit_Y tr- OrientV -> orient unitX tr- OrientTo v -> orient v tr- NoOrient -> mempty+ where+ tr = case po ^. polyType of+ PolyPolar ans szs -> polyPolarTrail ans szs+ PolySides ans szs -> polySidesTrail ans szs+ PolyRegular n r -> polyRegularTrail n r+ ori = case po ^. polyOrient of+ OrientH -> orient unit_Y tr+ OrientV -> orient unitX tr+ OrientTo v -> orient v tr+ NoOrient -> mempty -- | Generate the polygon described by the given options. polygon :: (InSpace V2 n t, TrailLike t) => PolygonOpts n -> t@@ -181,34 +194,36 @@ -- | Generate the located trail of a polygon specified by polar data -- (central angles and radii). See 'PolyPolar'.-polyPolarTrail :: OrderedField n => [Angle n] -> [n] -> Located (Trail V2 n)+polyPolarTrail :: OrderedField n => [Angle n] -> [n] -> Located (Trail V2 n) polyPolarTrail [] _ = emptyTrail `at` origin polyPolarTrail _ [] = emptyTrail `at` origin-polyPolarTrail ans (r:rs) = tr `at` p1- where- p1 = p2 (1,0) # scale r- tr = closeTrail . trailFromVertices $- zipWith- (\a l -> rotate a . scale l $ p2 (1,0))- (scanl (^+^) zero ans)- (r:rs)+polyPolarTrail ans (r : rs) = tr `at` p1+ where+ p1 = p2 (1, 0) # scale r+ tr =+ closeTrail . trailFromVertices $+ zipWith+ (\a l -> rotate a . scale l $ p2 (1, 0))+ (scanl (^+^) zero ans)+ (r : rs) -- | Generate the vertices of a polygon specified by side length and -- angles, and a starting point for the trail such that the origin -- is at the centroid of the vertices. See 'PolySides'.-polySidesTrail :: OrderedField n => [Angle n] -> [n] -> Located (Trail V2 n)+polySidesTrail :: OrderedField n => [Angle n] -> [n] -> Located (Trail V2 n) polySidesTrail ans ls = tr `at` (centroid ps # scale (-1))- where- ans' = scanl (^+^) zero ans- offsets = zipWith rotate ans' (map (unitY ^*) ls)- ps = scanl (.+^) origin offsets- tr = closeTrail . trailFromOffsets $ offsets+ where+ ans' = scanl (^+^) zero 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'.-polyRegularTrail :: OrderedField n => Int -> n -> Located (Trail V2 n)-polyRegularTrail n r = polyPolarTrail- (replicate (n - 1) $ fullTurn ^/ fromIntegral n)- (repeat r)+polyRegularTrail :: OrderedField n => Int -> n -> Located (Trail V2 n)+polyRegularTrail n r =+ polyPolarTrail+ (replicate (n - 1) $ fullTurn ^/ fromIntegral n)+ (repeat r) -- | Generate a transformation to orient a trail. @orient v t@ -- generates the smallest rotation such that one of the segments@@ -220,27 +235,31 @@ orientPoints :: OrderedField n => V2 n -> [Point V2 n] -> Transformation V2 n orientPoints _ [] = mempty orientPoints _ [_] = mempty-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 `dot` p) * norm (project w p)- sndOf3 (_,b,_) = b- -- a :: Angle (Scalar v)- a = minimumBy (comparing $ abs . view rad)- . map (angleFromNormal . (.-. x)) $ [n1,n2]- v' = signorm v- -- angleFromNormal :: v -> Angle (Scalar v)- angleFromNormal o- | leftTurn o' v' = phi- | otherwise = negated phi- where- o' = signorm o- theta = acos (v' `dot` o')- -- phi :: Angle (Scalar v)- phi- | theta <= tau/4 = tau/4 - theta @@ rad- | otherwise = theta - tau/4 @@ rad+orientPoints v xs@(y : ys) = rotation a+ where+ (n1, x, n2) =+ maximumBy+ (comparing (distAlong v . sndOf3))+ (zip3 (ys ++ [y]) xs (NE.last (y :| ys) : NE.init (y :| ys)))+ distAlong w ((.-. origin) -> p) = signum (w `dot` p) * norm (project w p)+ sndOf3 (_, b, _) = b+ -- a :: Angle (Scalar v)+ a =+ minimumBy (comparing $ abs . view rad)+ . map (angleFromNormal . (.-. x))+ $ [n1, n2]+ v' = signorm v+ -- angleFromNormal :: v -> Angle (Scalar v)+ angleFromNormal o+ | leftTurn o' v' = phi+ | otherwise = negated phi+ where+ o' = signorm o+ theta = acos (v' `dot` o')+ -- phi :: Angle (Scalar v)+ phi+ | theta <= tau / 4 = tau / 4 - theta @@ rad+ | otherwise = theta - tau / 4 @@ rad ------------------------------------------------------------ -- Function graphs@@ -251,49 +270,54 @@ -- the offchance that someone else finds them useful. -- | Pieces of a function graph can either be cycles or \"hairs\".-data GraphPart a = Cycle [a]- | Hair [a]+data GraphPart a+ = Cycle [a]+ | Hair [a] deriving (Show, Functor) -- | @orbits f n@ computes the graph of @f@ on the integers mod @n@. orbits :: (Int -> Int) -> Int -> [GraphPart Int] orbits f n = runST genOrbits- where- f_n i = f i `mod` n+ where+ f_n i = f i `mod` n - genOrbits :: ST s [GraphPart Int]- genOrbits = newArray (0,n-1) False >>= genOrbits'+ genOrbits :: ST s [GraphPart Int]+ genOrbits = newArray (0, n - 1) False >>= genOrbits' - genOrbits' :: STUArray s Int Bool -> ST s [GraphPart Int]- genOrbits' marks = liftM (concat . catMaybes) (forM [0 .. n-1] (genPart marks))+ genOrbits' :: STUArray s Int Bool -> ST s [GraphPart Int]+ genOrbits' marks = liftM (concat . catMaybes) (forM [0 .. n - 1] (genPart marks)) - genPart :: STUArray s Int Bool -> Int -> ST s (Maybe [GraphPart Int])- genPart marks i = do- tr <- markRho i marks- case tr of- [] -> return Nothing- _ -> return . Just . splitParts $ tr+ genPart :: STUArray s Int Bool -> Int -> ST s (Maybe [GraphPart Int])+ genPart marks i = do+ tr <- markRho i marks+ case tr of+ [] -> return Nothing+ _ -> return . Just . splitParts $ tr - markRho :: Int -> STUArray s Int Bool -> ST s [Int]- markRho i marks = do- isMarked <- readArray marks i- if isMarked- then return []- else writeArray marks i True >>- liftM (i:) (markRho (f_n i) marks)+ markRho :: Int -> STUArray s Int Bool -> ST s [Int]+ markRho i marks = do+ isMarked <- readArray marks i+ if isMarked+ then return []+ else+ writeArray marks i True+ >> liftM (i :) (markRho (f_n i) marks) - splitParts :: [Int] -> [GraphPart Int]- splitParts tr = hair ++ cyc- where hair | not (null tl) = [Hair $ tl ++ [f_n (last tl)]]- | otherwise = []- cyc | not (null body) = [Cycle body]- | otherwise = []- l = last tr- (tl, body) = span (/= f_n l) tr+ splitParts :: [Int] -> [GraphPart Int]+ splitParts tr = hair ++ cyc+ where+ hair+ | not (null tl) = [Hair $ tl ++ [f_n (last tl)]]+ | otherwise = []+ cyc+ | not (null body) = [Cycle body]+ | otherwise = []+ l = last tr+ (tl, body) = span (/= f_n l) tr -- | Generate a function graph from the given function and labels. mkGraph :: (Int -> Int) -> [a] -> [GraphPart a]-mkGraph f xs = (map . fmap) (xs!!) $ orbits f (length xs)+mkGraph f xs = (map . fmap) (xs !!) $ orbits f (length xs) ------------------------------------------------------------ -- Star polygons@@ -301,20 +325,20 @@ -- | Options for creating \"star\" polygons, where the edges connect -- possibly non-adjacent vertices.-data StarOpts = StarFun (Int -> Int)- -- ^ Specify the order in which the vertices should be- -- connected by a function that maps each vertex- -- index to the index of the vertex that should come- -- next. Indexing of vertices begins at 0.-- | StarSkip Int- -- ^ Specify a star polygon by a \"skip\". A skip of- -- 1 indicates a normal polygon, where edges go- -- between successive vertices. A skip of 2 means- -- that edges will connect every second vertex,- -- skipping one in between. Generally, a skip of- -- /n/ means that edges will connect every /n/th- -- vertex.+data StarOpts+ = -- | Specify the order in which the vertices should be+ -- connected by a function that maps each vertex+ -- index to the index of the vertex that should come+ -- next. Indexing of vertices begins at 0.+ StarFun (Int -> Int)+ | -- | Specify a star polygon by a \"skip\". A skip of+ -- 1 indicates a normal polygon, where edges go+ -- between successive vertices. A skip of 2 means+ -- that edges will connect every second vertex,+ -- skipping one in between. Generally, a skip of+ -- /n/ means that edges will connect every /n/th+ -- vertex.+ StarSkip Int -- | Create a generalized /star/ /polygon/. The 'StarOpts' are used -- to determine in which order the given vertices should be@@ -327,14 +351,15 @@ -- to be connected in several disjoint cycles. star :: OrderedField n => StarOpts -> [Point V2 n] -> Path V2 n star sOpts vs = graphToPath $ mkGraph f vs- where f = case sOpts of- StarFun g -> g- StarSkip k -> (+k)- graphToPath = mconcat . map partToPath-- partToPath (Cycle ps) = pathFromLocTrail- . mapLoc closeTrail- . fromVertices- $ ps+ where+ f = case sOpts of+ StarFun g -> g+ StarSkip k -> (+ k)+ graphToPath = mconcat . map partToPath - partToPath (Hair ps) = fromVertices ps+ partToPath (Cycle ps) =+ pathFromLocTrail+ . mapLoc closeTrail+ . fromVertices+ $ ps+ partToPath (Hair ps) = fromVertices ps
src/Diagrams/TwoD/Segment.hs view
@@ -1,16 +1,17 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+ -- Orphan Traced instances for Segment Closed V2 and FixedSegment V2. -- They can't go in Traced; but they shouldn't really go in -- Diagrams.Segment either because we only have Traced instances for -- the special case of R2.------------------------------------------------------------------------------+ -- | -- Module : Diagrams.TwoD.Segment -- Copyright : (c) 2012 diagrams-lib team (see LICENSE)@@ -19,47 +20,44 @@ -- -- Segments in two dimensions are special since we may meaningfully -- compute their point of intersection with a ray.-----------------------------------------------------------------------------------module Diagrams.TwoD.Segment- ( -- * Segment intersections-- intersectPointsS- , intersectPointsS'-- -- * Closest point on a segment+module Diagrams.TwoD.Segment (+ -- * Segment intersections+ intersectPointsS,+ intersectPointsS', - , closestPoint- , closestPoint'- , closestDistance- , closestDistance'- , closestParam- , closestParam'+ -- * Closest point on a segment+ closestPoint,+ closestPoint',+ closestDistance,+ closestDistance',+ closestParam,+ closestParam', - -- ** Low level functions- , segmentSegment- , lineSegment- )- where+ -- ** Low level functions+ segmentSegment,+ lineSegment,+)+where -import Control.Lens hiding (at, contains, transform, ( # ))-import Data.Maybe+import Control.Lens hiding (at, contains, transform, (#))+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe -import Diagrams.Core+import Diagrams.Core -import Diagrams.Direction-import Diagrams.Located-import Diagrams.Parametric-import Diagrams.Segment-import Diagrams.TwoD.Points-import Diagrams.TwoD.Segment.Bernstein-import Diagrams.TwoD.Transform-import Diagrams.TwoD.Types hiding (p2)-import Diagrams.TwoD.Vector+import Diagrams.Direction+import Diagrams.Located+import Diagrams.Parametric+import Diagrams.Segment+import Diagrams.TwoD.Points+import Diagrams.TwoD.Segment.Bernstein+import Diagrams.TwoD.Transform+import Diagrams.TwoD.Types hiding (p2)+import Diagrams.TwoD.Vector -import Linear.Affine-import Linear.Metric+import Linear.Affine+import Linear.Metric {- All instances of Traced should maintain the invariant that the list of traces is sorted in increasing order.@@ -109,21 +107,22 @@ -- tolerance. closestParam' :: OrderedField n => n -> FixedSegment V2 n -> P2 n -> [n] closestParam' _ (FLinear p0 p1) p- | t < 0 = [0]- | t > 1 = [1]+ | t < 0 = [0]+ | t > 1 = [1] | otherwise = [t]- where- vp = p .-. p0- v = p1 .-. p0- dp = vp `dot` v- t = dp / quadrance v+ where+ vp = p .-. p0+ v = p1 .-. p0+ dp = vp `dot` v+ t = dp / quadrance v closestParam' eps cb (P (V2 px py)) = bezierFindRoot eps poly 0 1- where- (bx, by) = bezierToBernstein cb- bx' = bernsteinDeriv bx- by' = bernsteinDeriv by- poly = (bx - listToBernstein [px, px, px, px]) * bx'- + (by - listToBernstein [py, py, py, py]) * by'+ where+ (bx, by) = bezierToBernstein cb+ bx' = bernsteinDeriv bx+ by' = bernsteinDeriv by+ poly =+ (bx - listToBernstein [px, px, px, px]) * bx'+ + (by - listToBernstein [py, py, py, py]) * by' ------------------------------------------------------------------------ -- Low level@@ -133,68 +132,70 @@ -- intersects. segmentSegment :: OrderedField n => n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n, P2 n)] segmentSegment eps s1 s2 =- case (s1,s2) of- (FCubic{}, FCubic{}) -> map (\(t1,t2) -> (t1,t2, s1 `atParam` t1))- $ bezierClip eps s1 s2- (FCubic{}, FLinear{}) -> map flip12 $ linearSeg (segLine s2) s1- _ -> linearSeg (segLine s1) s2 -- s1 is linear- where- linearSeg l s = filter (inRange . view _1) $ lineSegment eps l s- flip12 (a,b,c) = (b,a,c)+ case (s1, s2) of+ (FCubic {}, FCubic {}) ->+ map (\(t1, t2) -> (t1, t2, s1 `atParam` t1)) $+ bezierClip eps s1 s2+ (FCubic {}, FLinear {}) -> map flip12 $ linearSeg (segLine s2) s1+ _ -> linearSeg (segLine s1) s2 -- s1 is linear+ where+ linearSeg l s = filter (inRange . view _1) $ lineSegment eps l s+ flip12 (a, b, c) = (b, a, c) -- | Return the intersection points with the parameters at which the line and segment -- intersect. lineSegment :: OrderedField n => n -> Located (V2 n) -> FixedSegment V2 n -> [(n, n, P2 n)]-lineSegment _ l1 p@(FLinear p0 p1)- = map (\(tl,tp) -> (tl, tp, p `atParam` tp))- . filter (inRange . snd) . maybeToList $ lineLine l1 (mkLine p0 p1)-lineSegment eps (viewLoc -> (p,r)) cb = map addPoint params- where- params = bezierFindRoot eps (listToBernstein $ cb' ^.. each . _y) 0 1- cb' = transform (inv (rotationTo $ dir r)) . moveOriginTo p $ cb- --- addPoint bt = (lt, bt, intersect)- where- intersect = cb `atParam` bt- lt = (cb' `atParam` bt) ^. _x / norm r+lineSegment _ l1 p@(FLinear p0 p1) =+ map (\(tl, tp) -> (tl, tp, p `atParam` tp))+ . filter (inRange . snd)+ . maybeToList+ $ lineLine l1 (mkLine p0 p1)+lineSegment eps (viewLoc -> (p, r)) cb = map addPoint params+ where+ params = bezierFindRoot eps (listToBernstein $ cb' ^.. each . _y) 0 1+ cb' = transform (inv (rotationTo $ dir r)) . moveOriginTo p $ cb+ --+ addPoint bt = (lt, bt, intersect)+ where+ intersect = cb `atParam` bt+ lt = (cb' `atParam` bt) ^. _x / norm r -- Adapted from from kuribas's cubicbezier package https://github.com/kuribas/cubicbezier -- | Use the Bêzier clipping algorithm to return the parameters at which the -- Bêzier curves intersect. bezierClip :: OrderedField n => n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n)]-bezierClip eps p_ q_ = filter (allOf both inRange) -- sometimes this returns NaN- $ go p_ q_ 0 1 0 1 0 False- where- go p q tmin tmax umin umax clip revCurves- | isNothing chopInterval = []-+bezierClip eps p_ q_ =+ filter (allOf both inRange) $ -- sometimes this returns NaN+ go p_ q_ 0 1 0 1 0 False+ where+ go p q tmin tmax umin umax clip revCurves = case chopCubics p q of+ Nothing -> [] -- This check happens before the subdivision -- test to avoid non-termination as values -- transition to within epsilon.- | max (umax - umin) (tmax' - tmin') < eps =- if revCurves -- return parameters in correct order- then [ (avg umin umax, avg tmin' tmax') ]- else [ (avg tmin' tmax', avg umin umax ) ]-- -- split the curve if there isn't enough reduction- | clip > 0.8 && clip' > 0.8 =- if tmax' - tmin' > umax - umin -- split the longest segment- then let (pl, pr) = p' `splitAtParam` 0.5- tmid = avg tmin' tmax'- in go q pl umin umax tmin' tmid clip' (not revCurves) ++- go q pr umin umax tmid tmax' clip' (not revCurves)- else let (ql, qr) = q `splitAtParam` 0.5- umid = avg umin umax- in go ql p' umin umid tmin' tmax' clip' (not revCurves) ++- go qr p' umid umax tmin' tmax' clip' (not revCurves)-- -- iterate with the curves reversed.- | otherwise = go q p' umin umax tmin' tmax' clip' (not revCurves)- where- chopInterval = chopCubics p q- Just (tminChop, tmaxChop) = chopInterval- p' = section p tminChop tmaxChop+ Just (tminChop, tmaxChop)+ | max (umax - umin) (tmax' - tmin') < eps ->+ if revCurves -- return parameters in correct order+ then [(avg umin umax, avg tmin' tmax')]+ else [(avg tmin' tmax', avg umin umax)]+ -- split the curve if there isn't enough reduction+ | clip > 0.8 && clip' > 0.8 ->+ if tmax' - tmin' > umax - umin -- split the longest segment+ then+ let (pl, pr) = p' `splitAtParam` 0.5+ tmid = avg tmin' tmax'+ in go q pl umin umax tmin' tmid clip' (not revCurves)+ ++ go q pr umin umax tmid tmax' clip' (not revCurves)+ else+ let (ql, qr) = q `splitAtParam` 0.5+ umid = avg umin umax+ in go ql p' umin umid tmin' tmax' clip' (not revCurves)+ ++ go qr p' umid umax tmin' tmax' clip' (not revCurves)+ -- iterate with the curves reversed.+ | otherwise -> go q p' umin umax tmin' tmax' clip' (not revCurves)+ where+ p' = section p tminChop tmaxChop clip' = tmaxChop - tminChop tmin' = tmax * tminChop + tmin * (1 - tminChop) tmax' = tmax * tmaxChop + tmin * (1 - tmaxChop)@@ -202,37 +203,43 @@ -- | Find the zero of a 1D Bêzier curve of any degree. Note that this -- can be used as a Bernstein polynomial root solver by converting from -- the power basis to the Bernstein basis.-bezierFindRoot :: OrderedField n- => n -- ^ The accuracy- -> BernsteinPoly n -- ^ the Bernstein coefficients of the polynomial- -> n -- ^ The lower bound of the interval- -> n -- ^ The upper bound of the interval- -> [n] -- ^ The roots found-bezierFindRoot eps p tmin tmax+bezierFindRoot ::+ OrderedField n =>+ -- | The accuracy+ n ->+ -- | the Bernstein coefficients of the polynomial+ BernsteinPoly n ->+ -- | The lower bound of the interval+ n ->+ -- | The upper bound of the interval+ n ->+ -- | The roots found+ [n]+bezierFindRoot eps p initMin initMax -- If we generated the max number of roots and tmax is also a root -- (which is not among the generated ones), there must in fact be an -- infinite number of roots, so just include tmax.- | length roots == bernsteinDegree p && last roots /= tmax && abs (evaluateBernstein p tmax) <= eps- = roots ++ [tmax]+ | length roots == bernsteinDegree p && last roots /= initMax && abs (evaluateBernstein p initMax) <= eps =+ roots ++ [initMax] | otherwise = roots where -- Lazily take a number of roots at most the degree of the bernstein -- polynomial, to avoid generating a ton of roots in the case of a -- straight Bezier segment along the x-axis. See https://github.com/diagrams/diagrams-contrib/issues/91 .- roots = take (bernsteinDegree p) $ go p tmin tmax- go p tmin tmax- | isNothing chopInterval = []- | tmax' - tmin' < eps = [avg tmin' tmax']- | clip > 0.8 = let (p1, p2) = splitAtParam newP 0.5- tmid = tmin' + (tmax' - tmin') / 2- in go p1 tmin' tmid ++- go p2 tmid tmax'- | otherwise = bezierFindRoot eps newP tmin' tmax'- where- chopInterval = chopYs (bernsteinCoeffs p)- Just (tminChop, tmaxChop) = chopInterval- newP = section p tminChop tmaxChop- clip = tmaxChop - tminChop+ roots = take (bernsteinDegree p) $ go p initMin initMax+ go pInit tmin tmax = case chopYs (bernsteinCoeffs pInit) of+ Nothing -> []+ Just (tminChop, tmaxChop)+ | tmax' - tmin' < eps -> [avg tmin' tmax']+ | clip > 0.8 ->+ let (p1, p2) = splitAtParam newP 0.5+ tmid = tmin' + (tmax' - tmin') / 2+ in go p1 tmin' tmid+ ++ go p2 tmid tmax'+ | otherwise -> bezierFindRoot eps newP tmin' tmax'+ where+ newP = section pInit tminChop tmaxChop+ clip = tmaxChop - tminChop tmin' = tmax * tminChop + tmin * (1 - tminChop) tmax' = tmax * tmaxChop + tmin * (1 - tmaxChop) @@ -242,77 +249,79 @@ -- | An approximation of the fat line for a cubic Bêzier segment. Returns -- @(0,0)@ for a linear segment.-fatLine :: OrderedField n => FixedSegment V2 n -> (n,n)-fatLine (FCubic p0 p1 p2 p3)- = case (d1 > 0, d2 > 0) of- (True, True) -> (0, 0.75 * max d1 d2)- (False, False) -> (0.75 * min d1 d2, 0 )- (True, False) -> (4/9 * d2, 4/9 * d1 )- (False, True) -> (4/9 * d1, 4/9 * d2 )- where- d = lineDistance p0 p3- d1 = d p1; d2 = d p2-fatLine _ = (0,0)+fatLine :: OrderedField n => FixedSegment V2 n -> (n, n)+fatLine (FCubic p0 p1 p2 p3) =+ case (d1 > 0, d2 > 0) of+ (True, True) -> (0, 0.75 * max d1 d2)+ (False, False) -> (0.75 * min d1 d2, 0)+ (True, False) -> (4 / 9 * d2, 4 / 9 * d1)+ (False, True) -> (4 / 9 * d1, 4 / 9 * d2)+ where+ d = lineDistance p0 p3+ d1 = d p1+ d2 = d p2+fatLine _ = (0, 0) -chopYs :: OrderedField n => [n] -> Maybe (n, n)+chopYs :: OrderedField n => NonEmpty n -> Maybe (n, n) chopYs ds = chopHull 0 0 points- where- points = zipWith mkP2 [fromIntegral i / fromIntegral n | i <- [0..n]] ds- n = length ds - 1+ where+ points = NE.zipWith mkP2 (NE.zipWith (\i _ -> fromIntegral @Integer i / fromIntegral n) (0 :| [1 ..]) ds) ds+ n = NE.length ds - 1 -chopCubics :: OrderedField n => FixedSegment V2 n -> FixedSegment V2 n -> Maybe (n,n)-chopCubics p q@(FCubic q0 _ _ q3)- = chopHull dmin dmax dps- where- dps = zipWith mkP2 [0, 1/3, 2/3, 1] ds- ds = p ^.. each . to d- d = lineDistance q0 q3- --- (dmin,dmax) = fatLine q+chopCubics :: OrderedField n => FixedSegment V2 n -> FixedSegment V2 n -> Maybe (n, n)+chopCubics p q@(FCubic q0 _ _ q3) =+ chopHull dmin dmax dps+ where+ dps = NE.zipWith mkP2 (0 :| [1 / 3, 2 / 3, 1]) ds+ ds = NE.map d $ case p of+ FLinear p0 p1 -> p0 :| [p1]+ FCubic p0 p1 p2 p3 -> p0 :| [p1, p2, p3]+ d = lineDistance q0 q3+ --+ (dmin, dmax) = fatLine q chopCubics _ _ = Nothing -- Reduce the interval which the intersection is known to lie in using the fat -- line of one curve and convex hull of the points formed from the distance to -- the thin line of the other-chopHull :: OrderedField n => n -> n -> [P2 n] -> Maybe (n, n)+chopHull :: OrderedField n => n -> n -> NonEmpty (P2 n) -> Maybe (n, n) chopHull dmin dmax dps = do- tL <- testBelow upper $ testBetween (head upper) $ testAbove lower- tR <- testBelow (reverse upper) $ testBetween (last upper) $ testAbove (reverse lower)+ tL <- testBelow upper $ testBetween (NE.head upper) $ testAbove lower+ tR <- testBelow (NE.reverse upper) $ testBetween (NE.last upper) $ testAbove (NE.reverse lower) Just (tL, tR)- where- (upper, lower) = sortedConvexHull dps-- testBelow (p1@(P (V2 _ y1)) : p2@(P (V2 _ y2)) : ps) continue- | y1 >= dmin = continue- | y1 > y2 = Nothing- | y2 < dmin = testBelow (p2:ps) continue- | otherwise = Just $ intersectPt dmin p1 p2- testBelow _ _ = Nothing-- testBetween (P (V2 x y)) continue- | y <= dmax = Just x- | otherwise = continue+ where+ (upper, lower) = sortedConvexHull dps - testAbove (p1@(P (V2 _ y1)) : p2@(P (V2 _ y2)) : ps)- | y1 < y2 = Nothing- | y2 > dmax = testAbove (p2:ps)- | y2 - y1 == 0 = Nothing -- Check this condition to prevent- -- division by zero in `intersectPt`.- | otherwise = Just $ intersectPt dmax p1 p2- testAbove _ = Nothing+ testBelow (p1@(P (V2 _ y1)) :| p2@(P (V2 _ y2)) : ps) continue+ | y1 >= dmin = continue+ | y1 > y2 = Nothing+ | y2 < dmin = testBelow (p2 :| ps) continue+ | otherwise = Just $ intersectPt dmin p1 p2+ testBelow _ _ = Nothing - -- find the x value where the line through the two points- -- intersect the line y=d. Note that `y2 - y1 != 0` due- -- to checks above.- intersectPt d (P (V2 x1 y1)) (P (V2 x2 y2)) =- x1 + (d - y1) * (x2 - x1) / (y2 - y1)+ testBetween (P (V2 x y)) continue+ | y <= dmax = Just x+ | otherwise = continue + testAbove (p1@(P (V2 _ y1)) :| p2@(P (V2 _ y2)) : ps)+ | y1 < y2 = Nothing+ | y2 > dmax = testAbove (p2 :| ps)+ | y2 - y1 == 0 = Nothing -- Check this condition to prevent+ -- division by zero in `intersectPt`.+ | otherwise = Just $ intersectPt dmax p1 p2+ testAbove _ = Nothing + -- find the x value where the line through the two points+ -- intersect the line y=d. Note that `y2 - y1 != 0` due+ -- to checks above.+ intersectPt d (P (V2 x1 y1)) (P (V2 x2 y2)) =+ x1 + (d - y1) * (x2 - x1) / (y2 - y1) bezierToBernstein :: Fractional n => FixedSegment V2 n -> (BernsteinPoly n, BernsteinPoly n) bezierToBernstein seg =- (listToBernstein $ map (view _x) coeffs, listToBernstein $ map (view _y) coeffs)- where coeffs = toListOf each seg+ (listToBernstein $ map (view _x) coeffs, listToBernstein $ map (view _y) coeffs)+ where+ coeffs = toListOf each seg ------------------------------------------------------------------------ -- Lines@@ -325,41 +334,41 @@ -- @d@ as it may not be needed in all cases and @d@ may be zero. lineEquation :: Floating n => P2 n -> P2 n -> (n, n, n, n) lineEquation (P (V2 x1 y1)) (P (V2 x2 y2)) = (a, b, c, d)- where- c = -(x1*a + y1*b)- a = y1 - y2- b = x2 - x1- d = a*a + b*b+ where+ c = -(x1 * a + y1 * b)+ a = y1 - y2+ b = x2 - x1+ d = a * a + b * b -- | Return the distance from a point to the line. lineDistance :: (Ord n, Floating n) => P2 n -> P2 n -> P2 n -> n lineDistance p1 p2 p3@(P (V2 x y))- -- I have included the check that d' <= 0 in case- -- there exists some d > 0 where sqrt d == 0. I don't- -- think this can happen as sqrt is at least recommended- -- to be within one value of correct for sqrt and near- -- zero values get bigger.- | d <= 0 || d' <= 0 = norm (p1 .-. p3)- | otherwise = (a*x + b*y + c) / d'- where- (a, b, c, d) = lineEquation p1 p2- d' = sqrt d+ -- I have included the check that d' <= 0 in case+ -- there exists some d > 0 where sqrt d == 0. I don't+ -- think this can happen as sqrt is at least recommended+ -- to be within one value of correct for sqrt and near+ -- zero values get bigger.+ | d <= 0 || d' <= 0 = norm (p1 .-. p3)+ | otherwise = (a * x + b * y + c) / d'+ where+ (a, b, c, d) = lineEquation p1 p2+ d' = sqrt d -- clockwise :: (Num n, Ord n) => V2 n -> V2 n -> Bool -- clockwise a b = a `cross2` b <= 0 avg :: Fractional n => n -> n -> n-avg a b = (a + b)/2+avg a b = (a + b) / 2 -lineLine :: (Fractional n, Eq n) => Located (V2 n) -> Located (V2 n) -> Maybe (n,n)-lineLine (viewLoc -> (p,r)) (viewLoc -> (q,s))- | x1 == 0 && x2 /= 0 = Nothing -- parallel- | otherwise = Just (x3 / x1, x2 / x1) -- intersecting or collinear- where- x1 = r × s- x2 = v × r- x3 = v × s- v = q .-. p+lineLine :: (Fractional n, Eq n) => Located (V2 n) -> Located (V2 n) -> Maybe (n, n)+lineLine (viewLoc -> (p, r)) (viewLoc -> (q, s))+ | x1 == 0 && x2 /= 0 = Nothing -- parallel+ | otherwise = Just (x3 / x1, x2 / x1) -- intersecting or collinear+ where+ x1 = r × s+ x2 = v × r+ x3 = v × s+ v = q .-. p (×) :: Num n => V2 n -> V2 n -> n (×) = cross2@@ -368,12 +377,11 @@ mkLine p0 p1 = (p1 .-. p0) `at` p0 segLine :: InSpace v n (v n) => FixedSegment v n -> Located (v n)-segLine (FLinear p0 p1) = mkLine p0 p1+segLine (FLinear p0 p1) = mkLine p0 p1 segLine (FCubic p0 _ _ p3) = mkLine p0 p3 -- This function uses `defEps`, but is used in functions -- above that take an epsilon parameter. It would be nice -- to clearify the meaning of each of these epsilons. inRange :: (Fractional n, Ord n) => n -> Bool-inRange x = x < (1+defEps) && x > (-defEps)-+inRange x = x < (1 + defEps) && x > (-defEps)
src/Diagrams/TwoD/Segment/Bernstein.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE TypeFamilies #-}------------------------------------------------------------------------------+{-# LANGUAGE TypeFamilies #-}+ -- | -- Module : Diagrams.TwoD.Segment.Bernstein -- Copyright : (c) 2014-2015 diagrams-lib team (see LICENSE)@@ -10,129 +10,133 @@ -- Bernstein polynomials, used internally by code to find -- intersections of paths. This module is probably not of any -- relevance to most users of diagrams.-------------------------------------------------------------------------------module Diagrams.TwoD.Segment.Bernstein- ( BernsteinPoly (..)- , listToBernstein- , evaluateBernstein-- , degreeElevate- , bernsteinDeriv- , evaluateBernsteinDerivs- ) where+module Diagrams.TwoD.Segment.Bernstein (+ BernsteinPoly (..),+ listToBernstein,+ evaluateBernstein,+ degreeElevate,+ bernsteinDeriv,+ evaluateBernsteinDerivs,+) where -import Data.List (tails)-import Diagrams.Core.V-import Diagrams.Parametric-import Linear.V1+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty.Compat as NE+import Diagrams.Core.V+import Diagrams.Parametric+import Linear.V1 -- | Compute the binomial coefficients of degree n.-binomials :: Num n => Int -> [n]-binomials n = map fromIntegral $ scanl (\x m -> x * (n - m+1) `quot` m) 1 [1..n]+binomials :: Num n => Int -> NonEmpty n+binomials n = NE.map fromIntegral $ NE.scanl (\x m -> x * (n - m + 1) `quot` m) 1 [1 .. n] data BernsteinPoly n = BernsteinPoly { bernsteinDegree :: Int- , bernsteinCoeffs :: [n]- } deriving (Show, Functor)+ , bernsteinCoeffs :: NonEmpty n+ }+ deriving (Show, Functor) -type instance V (BernsteinPoly n) = V1-type instance N (BernsteinPoly n) = n+type instance V (BernsteinPoly n) = V1+type instance N (BernsteinPoly n) = n type instance Codomain (BernsteinPoly n) = V1 -- | Create a bernstein polynomial from a list of coëfficients. listToBernstein :: Fractional n => [n] -> BernsteinPoly n-listToBernstein [] = 0-listToBernstein l = BernsteinPoly (length l - 1) l+listToBernstein l = case NE.nonEmpty l of+ Nothing -> 0+ Just ne -> BernsteinPoly (length l - 1) ne -- | Degree elevate a bernstein polynomial a number of times. degreeElevate :: Fractional n => BernsteinPoly n -> Int -> BernsteinPoly n-degreeElevate b 0 = b+degreeElevate b 0 = b degreeElevate (BernsteinPoly lp p) times =- degreeElevate (BernsteinPoly (lp+1) (head p:inner p 1)) (times-1)- where- n = fromIntegral lp+ degreeElevate (BernsteinPoly (lp + 1) (NE.head p :| inner p 1)) (times - 1)+ where+ n = fromIntegral lp - inner [] _ = [0]- inner [a] _ = [a]- inner (a:b:rest) i = (i*a/(n+1) + b*(1 - i/(n+1))) : inner (b:rest) (i+1)+ inner (a :| []) _ = [a]+ inner (a :| b : rest) i = (i * a / (n + 1) + b * (1 - i / (n + 1))) : inner (b :| rest) (i + 1) -- | Evaluate the bernstein polynomial. evaluateBernstein :: Fractional n => BernsteinPoly n -> n -> n-evaluateBernstein (BernsteinPoly _ []) _ = 0-evaluateBernstein (BernsteinPoly _ [b]) _ = b-evaluateBernstein (BernsteinPoly lp (b':bs)) t = go t n (b'*u) 2 bs- where- u = 1-t- n = fromIntegral lp+evaluateBernstein (BernsteinPoly _ (b :| [])) _ = b+evaluateBernstein (BernsteinPoly lp (b' :| bs)) t = go t n (b' * u) 2 bs+ where+ u = 1 - t+ n = fromIntegral lp - go tn bc tmp _ [b] = tmp + tn*bc*b- go tn bc tmp i (b:rest) =- go (tn*t) -- tn- (bc*(n - i+1)/i) -- bc- ((tmp + tn*bc*b)*u) -- tmp- (i+1) -- i- rest- go _ _ _ _ [] = error "evaluateBernstein: impossible"+ go tn bc tmp _ [b] = tmp + tn * bc * b+ go tn bc tmp i (b : rest) =+ go+ (tn * t) -- tn+ (bc * (n - i + 1) / i) -- bc+ ((tmp + tn * bc * b) * u) -- tmp+ (i + 1) -- i+ rest+ go _ _ _ _ [] = error "evaluateBernstein: impossible" -- | Evaluate the bernstein polynomial and its derivatives. evaluateBernsteinDerivs :: Fractional n => BernsteinPoly n -> n -> [n] evaluateBernsteinDerivs b t | bernsteinDegree b == 0 = [evaluateBernstein b t]- | otherwise = evaluateBernstein b t : evaluateBernsteinDerivs (bernsteinDeriv b) t+ | otherwise = evaluateBernstein b t : evaluateBernsteinDerivs (bernsteinDeriv b) t -- | Find the derivative of a bernstein polynomial. bernsteinDeriv :: Fractional n => BernsteinPoly n -> BernsteinPoly n-bernsteinDeriv (BernsteinPoly 0 _) = 0-bernsteinDeriv (BernsteinPoly lp p) =- -- BernsteinPoly (lp-1) $ map (* fromIntegral lp) $ zipWith (-) (tail p) p- BernsteinPoly (lp-1) $ zipWith (\a b -> (a - b) * fromIntegral lp) (tail p) p+bernsteinDeriv (BernsteinPoly _ (_ :| [])) = 0+bernsteinDeriv (BernsteinPoly lp p@(_ :| (a1 : as))) =+ -- BernsteinPoly (lp-1) $ map (* fromIntegral lp) $ zipWith (-) (drop 1 p) p+ BernsteinPoly (lp - 1) $ NE.zipWith (\a b -> (a - b) * fromIntegral lp) (a1 :| as) p instance Fractional n => Parametric (BernsteinPoly n) where atParam b = V1 . evaluateBernstein b-instance Num n => DomainBounds (BernsteinPoly n)-instance Fractional n => EndValues (BernsteinPoly n)-instance Fractional n => Sectionable (BernsteinPoly n) where- splitAtParam = bernsteinSplit- reverseDomain (BernsteinPoly i xs) = BernsteinPoly i (reverse xs)+instance Num n => DomainBounds (BernsteinPoly n)+instance Fractional n => EndValues (BernsteinPoly n)+instance Fractional n => Sectionable (BernsteinPoly n) where+ splitAtParam = bernsteinSplit+ reverseDomain (BernsteinPoly i xs) = BernsteinPoly i (NE.reverse xs) -- | Split a bernstein polynomial. bernsteinSplit :: Num n => BernsteinPoly n -> n -> (BernsteinPoly n, BernsteinPoly n) bernsteinSplit (BernsteinPoly lp p) t =- (BernsteinPoly lp $ map head controls,- BernsteinPoly lp $ reverse $ map last controls)- where- interp a b = (1-t)*a + t*b+ ( BernsteinPoly lp $ NE.map NE.head controls+ , BernsteinPoly lp $ NE.reverse $ NE.map NE.last controls+ )+ where+ interp a b = (1 - t) * a + t * b - terp [_] = []- terp l = let ctrs = zipWith interp l (tail l)- in ctrs : terp ctrs- controls = p : terp p+ -- terp :: NonEmpty n -> [NonEmpty n]+ terp l@(_ :| as) = case NE.nonEmpty as of+ Nothing -> []+ Just as' ->+ let ctrs = NE.zipWith interp l as'+ in ctrs : terp ctrs+ controls = p :| terp p instance Fractional n => Num (BernsteinPoly n) where ba@(BernsteinPoly la a) + bb@(BernsteinPoly lb b)- | la < lb = BernsteinPoly lb $ zipWith (+) (bernsteinCoeffs $ degreeElevate ba $ lb - la) b- | la > lb = BernsteinPoly la $ zipWith (+) a (bernsteinCoeffs $ degreeElevate bb $ la - lb)- | otherwise = BernsteinPoly la $ zipWith (+) a b+ | la < lb = BernsteinPoly lb $ NE.zipWith (+) (bernsteinCoeffs $ degreeElevate ba $ lb - la) b+ | la > lb = BernsteinPoly la $ NE.zipWith (+) a (bernsteinCoeffs $ degreeElevate bb $ la - lb)+ | otherwise = BernsteinPoly la $ NE.zipWith (+) a b ba@(BernsteinPoly la a) - bb@(BernsteinPoly lb b)- | la < lb = BernsteinPoly lb $ zipWith (-) (bernsteinCoeffs $ degreeElevate ba (lb - la)) b- | la > lb = BernsteinPoly la $ zipWith (-) a (bernsteinCoeffs $ degreeElevate bb (la - lb))- | otherwise = BernsteinPoly la $ zipWith (-) a b+ | la < lb = BernsteinPoly lb $ NE.zipWith (-) (bernsteinCoeffs $ degreeElevate ba (lb - la)) b+ | la > lb = BernsteinPoly la $ NE.zipWith (-) a (bernsteinCoeffs $ degreeElevate bb (la - lb))+ | otherwise = BernsteinPoly la $ NE.zipWith (-) a b (BernsteinPoly la a) * (BernsteinPoly lb b) =- BernsteinPoly (la+lb) $- zipWith (flip (/)) (binomials (la + lb)) $- init $ map sum $- map (zipWith (*) a') (down b') ++- map (zipWith (*) (reverse b')) (tail $ tails a')- -- zipWith (zipWith (*)) (tail $ tails a') (repeat $ reverse b')- where down l = tail $ scanl (flip (:)) [] l -- [[1], [2, 1], [3, 2, 1], ...- a' = zipWith (*) a (binomials la)- b' = zipWith (*) b (binomials lb)+ BernsteinPoly (la + lb) $+ NE.zipWith (flip (/)) (binomials (la + lb)) $+ NE.map sum $+ NE.appendList+ (NE.map (NE.zipWith (*) a') (down b'))+ (map (NE.zipWith (*) (NE.reverse b')) (NE.tail $ NE.tails1 a'))+ where+ down (x :| xs) = NE.scanl (flip NE.cons) (x :| []) xs -- [[1], [2, 1], [3, 2, 1], ...+ a' = NE.zipWith (*) a (binomials la)+ b' = NE.zipWith (*) b (binomials lb) - fromInteger a = BernsteinPoly 0 [fromInteger a]+ fromInteger a = BernsteinPoly 0 (fromInteger a :| []) - signum (BernsteinPoly _ []) = 0- signum (BernsteinPoly _ (a:_)) = BernsteinPoly 0 [signum a]+ signum (BernsteinPoly _ (a :| _)) = BernsteinPoly 0 (signum a :| []) abs = fmap abs
src/Diagrams/TwoD/Shapes.hs view
@@ -1,12 +1,15 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-}- -- for Data.Semigroup +-- for Data.Semigroup+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module : Diagrams.TwoD.Shapes -- Copyright : (c) 2011 diagrams-lib team (see LICENSE)@@ -14,60 +17,58 @@ -- Maintainer : diagrams-discuss@googlegroups.com -- -- Various two-dimensional shapes.-----------------------------------------------------------------------------------module Diagrams.TwoD.Shapes- (- -- * Miscellaneous- hrule, vrule-- -- * Regular polygons-- , regPoly- , triangle- , eqTriangle- , square- , pentagon- , hexagon- , heptagon- , septagon- , octagon- , nonagon- , decagon- , hendecagon- , dodecagon-- -- * Other special polygons- , unitSquare- , rect+module Diagrams.TwoD.Shapes (+ -- * Miscellaneous+ hrule,+ vrule, - -- * Other shapes+ -- * Regular polygons+ regPoly,+ triangle,+ eqTriangle,+ square,+ pentagon,+ hexagon,+ heptagon,+ septagon,+ octagon,+ nonagon,+ decagon,+ hendecagon,+ dodecagon, - , roundedRect- , RoundedRectOpts(..), radiusTL, radiusTR, radiusBL, radiusBR- , roundedRect'- ) where+ -- * Other special polygons+ unitSquare,+ rect, -import Control.Lens (makeLenses, op, (&), (.~), (<>~), (^.))-import Data.Default-import Data.Semigroup+ -- * Other shapes+ roundedRect,+ RoundedRectOpts (..),+ radiusTL,+ radiusTR,+ radiusBL,+ radiusBR,+ roundedRect',+) where -import Diagrams.Core+import Control.Lens (makeLenses, op, (&), (.~), (<>~), (^.))+import Data.Default+import Data.Semigroup -import Diagrams.Angle-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.TwoD.Vector-import Diagrams.Util+import Diagrams.Core +import Diagrams.Angle+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.TwoD.Vector+import Diagrams.Util -- | Create a centered horizontal (L-R) line of the given length. --@@ -76,7 +77,7 @@ -- > hruleEx = vcat' (with & sep .~ 0.2) (map hrule [1..5]) -- > # centerXY # pad 1.1 hrule :: (InSpace V2 n t, TrailLike t) => n -> t-hrule d = trailLike $ trailFromSegments [straight $ r2 (d, 0)] `at` p2 (-d/2,0)+hrule d = trailLike $ trailFromSegments [straight $ r2 (d, 0)] `at` p2 (-d / 2, 0) -- | Create a centered vertical (T-B) line of the given length. --@@ -85,15 +86,19 @@ -- > vruleEx = hcat' (with & sep .~ 0.2) (map vrule [1, 1.2 .. 2]) -- > # centerXY # pad 1.1 vrule :: (InSpace V2 n t, TrailLike t) => n -> t-vrule d = trailLike $ trailFromSegments [straight $ r2 (0, -d)] `at` p2 (0,d/2)+vrule d = trailLike $ trailFromSegments [straight $ r2 (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. -- -- <<diagrams/src_Diagrams_TwoD_Shapes_unitSquareEx.svg#diagram=unitSquareEx&width=100>> unitSquare :: (InSpace V2 n t, TrailLike t) => t-unitSquare = polygon (def & polyType .~ PolyRegular 4 (sqrt 2 / 2)- & polyOrient .~ OrientH)+unitSquare =+ polygon+ ( def+ & polyType .~ PolyRegular 4 (sqrt 2 / 2)+ & polyOrient .~ OrientH+ ) -- > unitSquareEx = unitSquare # pad 1.1 # showOrigin @@ -112,26 +117,29 @@ -- -- <<diagrams/src_Diagrams_TwoD_Shapes_rectEx.svg#diagram=rectEx&width=150>> rect :: (InSpace V2 n t, TrailLike t) => n -> n -> t-rect w h = trailLike . head . op Path $ unitSquare # scaleX w # scaleY h+rect w h = case op Path $ unitSquare # scaleX w # scaleY h of+ (t : _) -> trailLike t+ -- This case can't happen---the unitSquare path is definitely non-empty.+ [] -> error "Impossible - unitSquare returned an empty path!" -- > 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 .+-- 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@@ -144,12 +152,15 @@ -- -- The polygon will be oriented with one edge parallel to the x-axis. regPoly :: (InSpace V2 n t, TrailLike t) => Int -> n -> t-regPoly n l = polygon (def & polyType .~- PolySides- (repeat (1/fromIntegral n @@ turn))- (replicate (n-1) l)- & polyOrient .~ OrientH- )+regPoly n l =+ polygon+ ( def+ & polyType+ .~ PolySides+ (repeat (1 / fromIntegral n @@ turn))+ (replicate (n - 1) l)+ & polyOrient .~ OrientH+ ) -- > shapeEx sh = sh 1 # pad 1.1 -- > triangleEx = shapeEx triangle@@ -238,15 +249,16 @@ ------------------------------------------------------------ -- Other shapes ------------------------------------------ -------------------------------------------------------------data RoundedRectOpts d = RoundedRectOpts { _radiusTL :: d- , _radiusTR :: d- , _radiusBL :: d- , _radiusBR :: d- }+data RoundedRectOpts d = RoundedRectOpts+ { _radiusTL :: d+ , _radiusTR :: d+ , _radiusBL :: d+ , _radiusBR :: d+ } makeLenses ''RoundedRectOpts -instance (Num d) => Default (RoundedRectOpts d) where+instance Num d => Default (RoundedRectOpts d) where def = RoundedRectOpts 0 0 0 0 -- | @roundedRect w h r@ generates a closed trail, or closed path@@ -269,54 +281,64 @@ -- > & radiusTR .~ -0.2 -- > & radiusBR .~ 0.1) -- > ]- roundedRect :: (InSpace V2 n t, TrailLike t, RealFloat n) => n -> n -> n -> t-roundedRect w h r = roundedRect' w h (def & radiusTL .~ r- & radiusBR .~ r- & radiusTR .~ r- & radiusBL .~ r)+roundedRect w h r =+ roundedRect'+ w+ h+ ( def+ & radiusTL .~ r+ & radiusBR .~ r+ & radiusTR .~ r+ & radiusBL .~ r+ ) -- | @roundedRect'@ works like @roundedRect@ but allows you to set the radius of -- each corner indivually, using @RoundedRectOpts@. The default corner radius is 0. -- Each radius can also be negative, which results in the curves being reversed -- to be inward instead of outward. roundedRect' :: (InSpace V2 n t, TrailLike t, RealFloat n) => n -> n -> RoundedRectOpts n -> t-roundedRect' w h opts- = 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)- <> mkCorner 1 rTL- <> seg (0, abs rTL + abs rBL - h)- <> mkCorner 2 rBL- <> seg (w - abs rBL - abs rBR, 0)- <> mkCorner 3 rBR- where seg = 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- -- as 50% of the edge in question.- rTL = clampCnr radiusTR radiusBL radiusBR radiusTL- rBL = clampCnr radiusBR radiusTL radiusTR radiusBL- rTR = clampCnr radiusTL radiusBR radiusBL radiusTR- rBR = clampCnr radiusBL radiusTR radiusTL radiusBR- clampCnr rx ry ro r = let (rx',ry',ro',r') = (opts^.rx, opts^.ry, opts^.ro, opts^.r)- in clampDiag ro' . clampAdj h ry' . clampAdj w rx' $ r'- -- prevent curves of adjacent corners from overlapping- clampAdj len adj r = if abs r > len/2- then sign r * max (len/2) (min (len - abs adj) (abs r))- else r- -- prevent inward curves of diagonally opposite corners from intersecting- clampDiag opp r = if r < 0 && opp < 0 && abs r > diag / 2- then sign r * max (diag / 2) (min (abs r) (diag + opp))- else r- sign n = if n < 0 then -1 else 1- mkCorner k r | r == 0 = mempty- | r < 0 = doArc 3 (-1)- | otherwise = doArc 0 1- where- doArc d s =- arc' r (xDir & _theta <>~ ((k+d)/4 @@ turn)) (s/4 @@ turn)+roundedRect' w h opts =+ 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)+ <> mkCorner 1 rTL+ <> seg (0, abs rTL + abs rBL - h)+ <> mkCorner 2 rBL+ <> seg (w - abs rBL - abs rBR, 0)+ <> mkCorner 3 rBR+ where+ seg = 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+ -- as 50% of the edge in question.+ rTL = clampCnr radiusTR radiusBL radiusBR radiusTL+ rBL = clampCnr radiusBR radiusTL radiusTR radiusBL+ rTR = clampCnr radiusTL radiusBR radiusBL radiusTR+ rBR = clampCnr radiusBL radiusTR radiusTL radiusBR+ clampCnr rx ry ro r =+ let (rx', ry', ro', r') = (opts ^. rx, opts ^. ry, opts ^. ro, opts ^. r)+ in clampDiag ro' . clampAdj h ry' . clampAdj w rx' $ r'+ -- prevent curves of adjacent corners from overlapping+ clampAdj len adj r =+ if abs r > len / 2+ then sign r * max (len / 2) (min (len - abs adj) (abs r))+ else r+ -- prevent inward curves of diagonally opposite corners from intersecting+ clampDiag opp r =+ if r < 0 && opp < 0 && abs r > diag / 2+ then sign r * max (diag / 2) (min (abs r) (diag + opp))+ else r+ sign n = if n < 0 then -1 else 1+ mkCorner k r+ | r == 0 = mempty+ | r < 0 = doArc 3 (-1)+ | otherwise = doArc 0 1+ where+ doArc d s =+ arc' r (xDir & _theta <>~ ((k + d) / 4 @@ turn)) (s / 4 @@ turn)
src/Diagrams/TwoD/Text.hs view
@@ -1,14 +1,16 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module : Diagrams.TwoD.Text -- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE)@@ -16,53 +18,80 @@ -- Maintainer : diagrams-discuss@googlegroups.com -- -- Very basic text primitives along with associated attributes.---------------------------------------------------------------------------------- module Diagrams.TwoD.Text ( -- * Creating text diagrams- Text(..), TextAlignment(..)- , text, topLeftText, alignedText, baselineText- , mkText, mkText'+ Text (..),+ TextAlignment (..),+ text,+ topLeftText,+ alignedText,+ baselineText,+ mkText,+ mkText', -- * Text attributes -- ** Font family- , Font(..), _Font- , getFont, font, _font+ Font (..),+ _Font,+ getFont,+ font,+ _font, -- ** Font size- , FontSize(..), _FontSize- , fontSize, recommendFontSize- , fontSizeN, fontSizeO, fontSizeL, fontSizeG- , getFontSize, fontSizeM- , _fontSizeR, _fontSize, _fontSizeU+ FontSize (..),+ _FontSize,+ fontSize,+ recommendFontSize,+ fontSizeN,+ fontSizeO,+ fontSizeL,+ fontSizeG,+ getFontSize,+ fontSizeM,+ _fontSizeR,+ _fontSize,+ _fontSizeU, -- ** Font slant- , FontSlant(..)- , getFontSlant, fontSlant, italic, oblique, _fontSlant+ FontSlant (..),+ getFontSlant,+ fontSlant,+ italic,+ oblique,+ _fontSlant, -- ** Font weight- , FontWeight(..)- , getFontWeight, fontWeight, bold, bolder, lighter, _fontWeight- , thinWeight, ultraLight, light, mediumWeight, heavy, semiBold, ultraBold-- ) where+ FontWeight (..),+ getFontWeight,+ fontWeight,+ bold,+ bolder,+ lighter,+ _fontWeight,+ thinWeight,+ ultraLight,+ light,+ mediumWeight,+ heavy,+ semiBold,+ ultraBold,+) where -import Control.Lens hiding (transform)-import Diagrams.Attributes (committed)-import Diagrams.Core-import Diagrams.Core.Envelope (pointEnvelope)-import Diagrams.TwoD.Attributes (recommendFillColor)-import Diagrams.TwoD.Types+import Control.Lens hiding (transform)+import Diagrams.Attributes (committed)+import Diagrams.Core+import Diagrams.Core.Envelope (pointEnvelope)+import Diagrams.TwoD.Attributes (recommendFillColor)+import Diagrams.TwoD.Types -import Data.Colour hiding (over)-import Data.Default-import Data.Monoid.Recommend-import Data.Semigroup-import Data.Typeable+import Data.Colour hiding (over)+import Data.Default+import Data.Monoid.Recommend+import Data.Semigroup+import Data.Typeable -import Linear.Affine+import Linear.Affine ------------------------------------------------------------ -- Text diagrams@@ -76,14 +105,14 @@ -- This constructor should not be used directly. Use 'text', -- 'alignedText' or 'baselineText'. data Text n = Text (T2 n) (TextAlignment n) String- deriving Typeable type instance V (Text n) = V2 type instance N (Text n) = n instance Floating n => Transformable (Text n) where transform t (Text tt a s) = Text (t <> tt <> t') a s- where t' = scaling (1 / avgScale t)+ where+ t' = scaling (1 / avgScale t) instance Floating n => HasOrigin (Text n) where moveOriginTo p = translate (origin .-. p)@@ -96,25 +125,29 @@ -- | Make a text from a 'TextAlignment', recommending a fill colour of -- 'black' and 'fontSize' of @'local' 1@.-mkText :: (TypeableFloat n, Renderable (Text n) b)- => TextAlignment n -> String -> QDiagram b V2 n Any-mkText a = recommendFillColor black- -- See Note [recommendFillColor]- . recommendFontSize (local 1)- -- See Note [recommendFontSize]- . mkText' a+mkText ::+ (TypeableFloat n, Renderable (Text n) b) =>+ TextAlignment n -> String -> QDiagram b V2 n Any+mkText a =+ recommendFillColor black+ -- See Note [recommendFillColor]+ . recommendFontSize (local 1)+ -- See Note [recommendFontSize]+ . mkText' a -- | Make a text from a 'TextAlignment' without any default size or fill -- colour. This is useful is you want to recommend your own using -- 'recommendFillColor' or 'recommendFontSize'.-mkText' :: (TypeableFloat n, Renderable (Text n) b)- => TextAlignment n -> String -> QDiagram b V2 n Any-mkText' a t = mkQD (Prim $ Text mempty a t)- (pointEnvelope origin)- mempty- mempty- mempty-+mkText' ::+ (TypeableFloat n, Renderable (Text n) b) =>+ TextAlignment n -> String -> QDiagram b V2 n Any+mkText' a t =+ mkQD+ (Prim $ Text mempty a t)+ (pointEnvelope origin)+ mempty+ mempty+ mempty -- ~~~~ Note [recommendFillColor] @@ -130,7 +163,9 @@ -- 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++-- * 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@@ -168,8 +203,9 @@ -- and descent, rather than the height of the particular string. -- -- Note that it /takes up no space/.-alignedText :: (TypeableFloat n, Renderable (Text n) b)- => n -> n -> String -> QDiagram b V2 n Any+alignedText ::+ (TypeableFloat n, Renderable (Text n) b) =>+ n -> n -> String -> QDiagram b V2 n Any alignedText w h = mkText (BoxAlignedText w h) -- | Create a primitive text diagram from the given string, with the@@ -178,8 +214,9 @@ -- graphics library. -- -- Note that it /takes up no space/.-baselineText :: (TypeableFloat n, Renderable (Text n) b)- => String -> QDiagram b V2 n Any+baselineText ::+ (TypeableFloat n, Renderable (Text n) b) =>+ String -> QDiagram b V2 n Any baselineText = mkText BaselineText ------------------------------------------------------------@@ -192,7 +229,7 @@ -- | The @Font@ attribute specifies the name of a font family. Inner -- @Font@ attributes override outer ones. newtype Font = Font (Last String)- deriving (Typeable, Semigroup, Eq)+ deriving (Semigroup, Eq) _Font :: Iso' Font String _Font = iso getFont (Font . Last)@@ -217,22 +254,24 @@ -- | The @FontSize@ attribute specifies the size of a font's -- em-square. Inner @FontSize@ attributes override outer ones. newtype FontSize n = FontSize (Recommend (Last n))- deriving (Typeable, Semigroup)+ deriving (Semigroup) -- not sure why this can't be derived instance Functor FontSize where fmap f (FontSize (Recommend (Last a))) = FontSize (Recommend (Last (f a)))- fmap f (FontSize (Commit (Last a))) = FontSize (Commit (Last (f a)))+ fmap f (FontSize (Commit (Last a))) = FontSize (Commit (Last (f a))) _FontSize :: Iso' (FontSize n) (Recommend n) _FontSize = iso getter setter- where getter (FontSize (Recommend (Last a))) = Recommend a- getter (FontSize (Commit (Last a))) = Commit a- setter (Recommend a) = FontSize $ Recommend (Last a)- setter (Commit a) = FontSize $ Commit (Last a)- -- = iso (\(FontSize a) -> a) FontSize . mapping _Wrapped- -- once we depend on monoid-extras-0.4+ where+ getter (FontSize (Recommend (Last a))) = Recommend a+ getter (FontSize (Commit (Last a))) = Commit a+ setter (Recommend a) = FontSize $ Recommend (Last a)+ setter (Commit a) = FontSize $ Commit (Last a) +-- = iso (\(FontSize a) -> a) FontSize . mapping _Wrapped+-- once we depend on monoid-extras-0.4+ _FontSizeM :: Iso' (FontSizeM n) (Measured n (Recommend n)) _FontSizeM = mapping _FontSize @@ -246,7 +285,7 @@ -- | Extract the size from a @FontSize@ attribute. getFontSize :: FontSize n -> n getFontSize (FontSize (Recommend (Last s))) = s-getFontSize (FontSize (Commit (Last s))) = s+getFontSize (FontSize (Commit (Last s))) = s -- | Set the font size, that is, the size of the font's em-square as -- measured within the current local vector space. The default size@@ -289,7 +328,7 @@ _fontSize :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measure n) _fontSize = _fontSizeR . mapping committed -_fontSizeU :: (Typeable n) => Lens' (Style v n) (Maybe n)+_fontSizeU :: Typeable n => Lens' (Style v n) (Maybe n) _fontSizeU = atAttr . mapping (_FontSize . committed) --------------------------------------------------@@ -298,12 +337,13 @@ -- | The @FontSlantA@ attribute specifies the slant (normal, italic, -- or oblique) that should be used for all text within a diagram. -- Inner @FontSlantA@ attributes override outer ones.-data FontSlant = FontSlantNormal- | FontSlantItalic- | FontSlantOblique- deriving (Eq, Show, Typeable, Ord)+data FontSlant+ = FontSlantNormal+ | FontSlantItalic+ | FontSlantOblique+ deriving (Eq, Show, Ord) -instance AttributeClass FontSlant where+instance AttributeClass FontSlant instance Semigroup FontSlant where _ <> b = b @@ -338,19 +378,19 @@ -- | The @FontWeightA@ attribute specifies the weight (normal or bold) -- that should be used for all text within a diagram. Inner -- @FontWeightA@ attributes override outer ones.-data FontWeight = FontWeightNormal- | FontWeightBold- | FontWeightBolder- | FontWeightLighter- | FontWeightThin- | FontWeightUltraLight- | FontWeightLight- | FontWeightMedium- | FontWeightSemiBold- | FontWeightUltraBold- | FontWeightHeavy- deriving (Eq,- Ord, Show, Typeable)+data FontWeight+ = FontWeightNormal+ | FontWeightBold+ | FontWeightBolder+ | FontWeightLighter+ | FontWeightThin+ | FontWeightUltraLight+ | FontWeightLight+ | FontWeightMedium+ | FontWeightSemiBold+ | FontWeightUltraBold+ | FontWeightHeavy+ deriving (Eq, Ord, Show) instance AttributeClass FontWeight
src/Diagrams/Util.hs view
@@ -203,7 +203,7 @@ findSandbox paths = runMaybeT $ pathsTest <|> diaSB <|> envDB <|> wdConfig where -- first path in environment- lookEnv = MaybeT . (fmap . fmap) (head . splitSearchPath) . lookupEnv+ lookEnv = MaybeT . fmap ((listToMaybe . splitSearchPath) =<<) . lookupEnv envDB = foldMaybeT lookEnv ["GHC_PACKAGE_PATH", "HSENV", "PACKAGE_DB_FOR_GHC"] -- test if path points directly to db or contains a config file