diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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' diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -1,5 +1,5 @@ Name: diagrams-lib -Version: 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 diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -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 diff --git a/src/Diagrams/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs --- a/src/Diagrams/Backend/CmdLine.hs +++ b/src/Diagrams/Backend/CmdLine.hs @@ -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 -- . --- ------------------------------------------------------------------------------ - -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) diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -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 @@ -- <> -- -- > 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 diff --git a/src/Diagrams/CubicSpline.hs b/src/Diagrams/CubicSpline.hs --- a/src/Diagrams/CubicSpline.hs +++ b/src/Diagrams/CubicSpline.hs @@ -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 . 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) diff --git a/src/Diagrams/CubicSpline/Boehm.hs b/src/Diagrams/CubicSpline/Boehm.hs --- a/src/Diagrams/CubicSpline/Boehm.hs +++ b/src/Diagrams/CubicSpline/Boehm.hs @@ -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/, -- --- ------------------------------------------------------------------------------ -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 diff --git a/src/Diagrams/CubicSpline/Internal.hs b/src/Diagrams/CubicSpline/Internal.hs --- a/src/Diagrams/CubicSpline/Internal.hs +++ b/src/Diagrams/CubicSpline/Internal.hs @@ -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 diff --git a/src/Diagrams/CubicSpline/NonSingleton.hs b/src/Diagrams/CubicSpline/NonSingleton.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/CubicSpline/NonSingleton.hs @@ -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 diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -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 diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -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 diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -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 diff --git a/src/Diagrams/Size.hs b/src/Diagrams/Size.hs --- a/src/Diagrams/Size.hs +++ b/src/Diagrams/Size.hs @@ -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 diff --git a/src/Diagrams/ThreeD/Attributes.hs b/src/Diagrams/ThreeD/Attributes.hs --- a/src/Diagrams/ThreeD/Attributes.hs +++ b/src/Diagrams/ThreeD/Attributes.hs @@ -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 diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -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 diff --git a/src/Diagrams/ThreeD/Light.hs b/src/Diagrams/ThreeD/Light.hs --- a/src/Diagrams/ThreeD/Light.hs +++ b/src/Diagrams/ThreeD/Light.hs @@ -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 diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -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 diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -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'. --- --- <> --- --- > 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)@. --- --- <> --- --- > 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. --- --- <> --- --- > 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 --- @ --- --- <> --- --- > 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. --- --- <> --- --- > 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'. +-- +-- <> +-- +-- > 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)@. +-- +-- <> +-- +-- > 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. +-- +-- <> +-- +-- > 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 +-- @ +-- +-- <> +-- +-- > 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. +-- +-- <> +-- +-- > 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 diff --git a/src/Diagrams/Transform/ScaleInv.hs b/src/Diagrams/Transform/ScaleInv.hs --- a/src/Diagrams/Transform/ScaleInv.hs +++ b/src/Diagrams/Transform/ScaleInv.hs @@ -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) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -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: -- . --- ------------------------------------------------------------------------------ - - -module Diagrams.TwoD.Arrow - ( -- * Examples - -- ** Example 1 --- | <> --- --- > -- 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 - --- | <> --- --- > -- 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' + -- | <> + -- + -- > -- 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 + -- | <> + -- + -- > -- 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') diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -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) -- | <> -- > spikeEx = drawHead spike spike :: RealFloat n => ArrowHT n -spike = arrowheadSpike (3/8 @@ turn) +spike = arrowheadSpike (3 / 8 @@ turn) -- | <> -- > thornEx = drawHead thorn thorn :: RealFloat n => ArrowHT n -thorn = arrowheadThorn (3/8 @@ turn) +thorn = arrowheadThorn (3 / 8 @@ turn) -- | <> -- > dartEx = drawHead dart dart :: RealFloat n => ArrowHT n -dart = arrowheadDart (2/5 @@ turn) +dart = arrowheadDart (2 / 5 @@ turn) -- | <> -- > 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) -- | <> -- > blockEx = drawTail block block :: RealFloat n => ArrowHT n -block = arrowtailBlock (7/16 @@ turn) +block = arrowtailBlock (7 / 16 @@ turn) diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -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) diff --git a/src/Diagrams/TwoD/Image.hs b/src/Diagrams/TwoD/Image.hs --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -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 - diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -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 -- . --- ------------------------------------------------------------------------------ -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). -- -- <> --- -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: -- -- <> --- -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] diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -1,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 - -- . - | EvenOdd -- ^ Interior points are those where a ray - -- extended infinitely in a particular direction crosses - -- the path an odd number of times. See - -- . - deriving (Show, Typeable, Eq, Ord) + = -- | Interior points are those with a nonzero + -- /winding/ /number/. See + -- . + Winding + | -- | Interior points are those where a ray + -- extended infinitely in a particular direction crosses + -- the path an odd number of times. See + -- . + 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. diff --git a/src/Diagrams/TwoD/Points.hs b/src/Diagrams/TwoD/Points.hs --- a/src/Diagrams/TwoD/Points.hs +++ b/src/Diagrams/TwoD/Points.hs @@ -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 diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -1,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 diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -1,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) diff --git a/src/Diagrams/TwoD/Segment/Bernstein.hs b/src/Diagrams/TwoD/Segment/Bernstein.hs --- a/src/Diagrams/TwoD/Segment/Bernstein.hs +++ b/src/Diagrams/TwoD/Segment/Bernstein.hs @@ -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 diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -1,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. -- -- <> 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 @@ -- -- <> 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) diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -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 diff --git a/src/Diagrams/Util.hs b/src/Diagrams/Util.hs --- a/src/Diagrams/Util.hs +++ b/src/Diagrams/Util.hs @@ -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