diagrams-lib 1.4.2.3 → 1.4.3

raw patch · 32 files changed

+367/−258 lines, 32 filesdep +QuickCheckdep +faildep ~JuicyPixelsdep ~basedep ~hashablePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: QuickCheck, fail

Dependency ranges changed: JuicyPixels, base, hashable, intervals, lens, linear, optparse-applicative, semigroups

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−1
• diagrams-lib.cabal +17/−13
• src/Diagrams/Align.hs +1/−1
• src/Diagrams/Animation.hs +1/−6
• src/Diagrams/Animation/Active.hs +0/−5
• src/Diagrams/Attributes.hs +1/−5
• src/Diagrams/Attributes/Compile.hs +5/−1
• src/Diagrams/Backend/CmdLine.hs +11/−7
• src/Diagrams/Located.hs +6/−8
• src/Diagrams/Path.hs +8/−25
• src/Diagrams/Segment.hs +1/−1
• src/Diagrams/Size.hs +6/−17
• src/Diagrams/ThreeD/Camera.hs +1/−13
• src/Diagrams/ThreeD/Deform.hs +1/−1
• src/Diagrams/ThreeD/Shapes.hs +6/−11
• src/Diagrams/Trail.hs +39/−49
• src/Diagrams/Transform/Matrix.hs +0/−1
• src/Diagrams/Transform/ScaleInv.hs +0/−4
• src/Diagrams/TwoD.hs +1/−1
• src/Diagrams/TwoD/Arc.hs +8/−4
• src/Diagrams/TwoD/Arrow.hs +1/−5
• src/Diagrams/TwoD/Attributes.hs +1/−3
• src/Diagrams/TwoD/Combinators.hs +20/−7
• src/Diagrams/TwoD/Image.hs +3/−4
• src/Diagrams/TwoD/Polygons.hs +17/−21
• src/Diagrams/TwoD/Segment.hs +46/−28
• src/Diagrams/TwoD/Text.hs +1/−5
• test/Diagrams/Test/Trail.hs +66/−1
• test/Diagrams/Test/TwoD.hs +14/−2
• test/Diagrams/Test/TwoD/Segment.hs +54/−0
• test/Instances.hs +6/−1
• test/Test.hs +9/−7

@@ -1,4 +1,19 @@-## [v1.4.2.3](https://github.com/diagrams/diagrams-lib/tree/v1.4.2.2) (2018-06-11)+## [v1.4.3](https://github.com/diagrams/diagrams-lib/tree/v1.4.3) (2019-11-06)++- Bumps to upper bounds, to allow building with:+    - `base-4.13` (tested with GHC 8.8.1)+    - `intervals-0.9`+    - `semigroups-0.19`+    - `hashable-1.3`+- Many bug fixes, including+    - [#313](https://github.com/diagrams/diagrams-lib/issues/313) (`combineBoundaries`)+    - [#322](https://github.com/diagrams/diagrams-lib/issues/322), [#329](https://github.com/diagrams/diagrams-lib/issues/329) (`section`)+    - [#325](https://github.com/diagrams/diagrams-lib/pull/325)+      (Bezier/Bezier intersection)+    - [#339](https://github.com/diagrams/diagrams-lib/pull/339) (`perspectiveZ1`)+- Added derived `Eq` and `Ord` instances for `FixedSegment`++## [v1.4.2.3](https://github.com/diagrams/diagrams-lib/tree/v1.4.2.3) (2018-06-11)  - Bug fix for `extrudeEnvelope` and friends ([#316](https://github.com/diagrams/diagrams-lib/issues/316)) 

@@ -1,5 +1,5 @@ Name:                diagrams-lib-Version:             1.4.2.3+Version:             1.4.3 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@@ -9,8 +9,8 @@                      creating diagrams.  To get started using it, see                      the "Diagrams" module, and refer to the tutorials and                      documentation on the diagrams website,-                     <http://projects.haskell.org/diagrams>.-Homepage:            http://projects.haskell.org/diagrams+                     <http://diagrams.github.io>.+Homepage:            http://diagrams.github.io License:             BSD3 License-file:        LICENSE Author:              Brent Yorgey@@ -21,7 +21,7 @@ Cabal-version:       1.18 Extra-source-files:  CHANGELOG.md, README.markdown, diagrams/*.svg Extra-doc-files:     diagrams/*.svg-Tested-with:         GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2+Tested-with:         GHC ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.3 || ==8.6.5 || ==8.8.1 Source-repository head   type:     git   location: http://github.com/diagrams/diagrams-lib.git@@ -100,10 +100,10 @@                        Diagrams.TwoD.Types,                        Diagrams.TwoD.Vector,                        Diagrams.Util-  Build-depends:       base >= 4.6 && < 4.12,-                       containers >= 0.3 && < 0.6,+  Build-depends:       base >= 4.8 && < 4.14,+                       containers >= 0.3 && < 0.7,                        array >= 0.3 && < 0.6,-                       semigroups >= 0.3.4 && < 0.19,+                       semigroups >= 0.3.4 && < 0.20,                        monoid-extras >= 0.3 && < 0.6,                        dual-tree >= 0.2 && < 0.3,                        diagrams-core >= 1.4 && < 1.5,@@ -112,13 +112,13 @@                        colour >= 2.3.2 && < 2.4,                        data-default-class < 0.2,                        fingertree >= 0.1 && < 0.2,-                       intervals >= 0.7 && < 0.9,-                       lens >= 4.6 && < 4.17,+                       intervals >= 0.7 && < 0.10,+                       lens >= 4.6 && < 4.19,                        tagged >= 0.7,-                       optparse-applicative >= 0.11 && < 0.15,+                       optparse-applicative >= 0.11 && < 0.16,                        filepath,-                       JuicyPixels >= 3.1.5 && < 3.3,-                       hashable >= 1.1 && < 1.3,+                       JuicyPixels >= 3.3.4 && < 3.4,+                       hashable >= 1.1 && < 1.4,                        linear >= 1.20.1 && < 1.21,                        adjunctions >= 4.0 && < 5.0,                        distributive >=0.2.2 && < 1.0,@@ -135,6 +135,8 @@                        bytestring >=0.9 && <0.11   if impl(ghc < 7.6)     Build-depends: ghc-prim+  if !impl(ghc >= 8.0)+    build-depends: fail >= 4.9.0.0 && <4.10   Hs-source-dirs:      src   ghc-options: -Wall   default-language:    Haskell2010@@ -153,14 +155,16 @@                , Diagrams.Test.Transform                , Diagrams.Test.Transform.Matrix                , Diagrams.Test.TwoD.Offset+               , Diagrams.Test.TwoD.Segment                , Diagrams.Test.TwoD                , Diagrams.Test.Angle                , Instances   hs-source-dirs: test   build-depends:       base,-                       tasty >= 0.10 && < 1.2,+                       tasty >= 0.10 && < 1.3,                        tasty-hunit >= 0.9.2 && < 0.11,                        tasty-quickcheck >= 0.8 && < 0.11,+                       QuickCheck >= 2.7,                        deepseq >= 1.3 && < 1.5,                        diagrams-lib,                        lens,

@@ -95,7 +95,7 @@   :: (InSpace v n a, Metric v, Ord n, F.Foldable f)   => (v n -> a -> Point v n) -> v n -> f a -> Point v n combineBoundaries b v fa-    = b v $ F.maximumBy (comparing (quadrance . (.-. origin) . b v)) fa+  = b v $ F.maximumBy (comparing (dot v . (.-.origin) . b v)) fa  instance (Metric v, OrderedField n) => Alignable (Envelope v n) where   defaultBoundary = envelopeBoundary

@@ -1,5 +1,4 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies          #-}@@ -32,10 +31,6 @@        ) where  import           Data.Active-#if __GLASGOW_HASKELL__ < 710-import           Control.Applicative       ((<$>))-import           Data.Foldable             (foldMap)-#endif import           Data.Semigroup  import           Diagrams.Core

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP          #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -37,10 +36,6 @@ -----------------------------------------------------------------------------  module Diagrams.Animation.Active where--#if __GLASGOW_HASKELL__ < 710-import           Control.Applicative (pure, (<$>))-#endif  import           Diagrams.Core import           Diagrams.TrailLike

@@ -1,5 +1,4 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP                        #-}+{-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE ExistentialQuantification  #-}@@ -88,9 +87,6 @@    ) where -#if __GLASGOW_HASKELL__ < 710-import           Control.Applicative-#endif import           Control.Lens          hiding (none, over) import           Data.Colour import           Data.Colour.RGBSpace  (RGB (..))

@@ -2,6 +2,10 @@ {-# LANGUAGE GADTs               #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-}++{-# OPTIONS_GHC -fno-warn-unused-imports #-}+  -- for Data.Semigroup+ ----------------------------------------------------------------------------- -- | -- Module      :  Diagrams.Attributes.Compile@@ -22,7 +26,7 @@ import           Control.Arrow       (second) import           Control.Lens        ((%~), (&), _Wrapping') import qualified Data.HashMap.Strict as HM-import           Data.Semigroup      ((<>))+import           Data.Semigroup import           Data.Tree           (Tree (..))  import           Diagrams.Core

@@ -1,4 +1,5 @@-{-# LANGUAGE ConstrainedClassMethods     #-}+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE ConstrainedClassMethods   #-} {-# LANGUAGE DeriveDataTypeable        #-} {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-}@@ -84,12 +85,18 @@  import           Control.Monad             (forM_, forever, unless, when) +-- MonadFail comes from Prelude in base-4.13 and up+#if !MIN_VERSION_base(4,13,0)+import           Control.Monad.Fail        (MonadFail)+#endif+ 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.IORef import           Data.List                 (delete) import           Data.Maybe                (fromMaybe)@@ -303,7 +310,7 @@ --   example, @\"0xfc4\"@ is the same as @\"0xffcc44\"@.  When eight or six --   digits are given each pair of digits is a color or alpha channel with the --   order being red, green, blue, alpha.-readHexColor :: (Applicative m, Monad m) => String -> m (AlphaColour Double)+readHexColor :: (Applicative m, MonadFail m) => String -> m (AlphaColour Double) readHexColor cs = case cs of   ('0':'x':hs) -> handle hs   ('#':hs)     -> handle hs@@ -429,10 +436,7 @@   -- value or ending the program with an error or help message.   -- Typically the default instance will work.  If a different help message   -- or parsing behavior is desired a new implementation is appropriate.-  ---  -- Note the @d@ argument should only be needed to fix the type @d@.  Its-  -- value should not be relied on as a parameter.-  mainArgs :: Parseable (MainOpts d) => d -> IO (MainOpts d)+  mainArgs :: Parseable (MainOpts d) => proxy d -> IO (MainOpts d)   mainArgs _ = defaultOpts parser    -- | Backend specific work of rendering with the given options and mainable@@ -457,7 +461,7 @@   -- implementation should be used to handle more complex interactions with the user.   mainWith :: Parseable (MainOpts d) => d -> IO ()   mainWith d = do-    opts <- mainArgs d+    opts <- mainArgs (Identity d)     mainRender opts d  -- | This instance allows functions resulting in something that is 'Mainable' to

@@ -1,11 +1,10 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE UndecidableInstances  #-}-{-# LANGUAGE DeriveGeneric         #-} ----------------------------------------------------------------------------- -- | -- Module      :  Diagrams.Located@@ -28,9 +27,6 @@     where  import           Control.Lens            (Lens, Lens')-#if __GLASGOW_HASKELL__ < 710-import           Data.Functor            ((<$>))-#endif import           Text.Read  import           Linear.Affine@@ -41,8 +37,8 @@ import           Diagrams.Core.Transform import           Diagrams.Parametric -import           GHC.Generics (Generic)-import           Data.Serialize (Serialize)+import           Data.Serialize          (Serialize)+import           GHC.Generics            (Generic)  -- | \"Located\" things, /i.e./ things with a concrete location: --   intuitively, @Located a ~ (Point, a)@.  Wrapping a translationally@@ -174,6 +170,8 @@     => Sectionable (Located a) where   splitAtParam (Loc x a) p = (Loc x a1, Loc (x .+^ (a `atParam` p)) a2)     where (a1,a2) = splitAtParam a p++  section (Loc x a) p1 p2 = Loc (x .+^ (a `atParam` p1)) (section a p1 p2)    reverseDomain (Loc x a) = Loc (x .+^ y) (reverseDomain a)     where y = a `atParam` domainUpper a

@@ -1,8 +1,6 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP                        #-}-#if __GLASGOW_HASKELL__ >= 707+{-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE DeriveDataTypeable         #-}-#endif+{-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -12,7 +10,6 @@ {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE ViewPatterns               #-}-{-# LANGUAGE DeriveGeneric              #-}  {-# OPTIONS_GHC -fno-warn-unused-imports #-}   -- for Data.Semigroup@@ -68,10 +65,10 @@         ) where -import           Control.Arrow        ((***))-import           Control.Lens         hiding ((#), transform, at)-import qualified Data.Foldable        as F-import           Data.List            (partition)+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 @@ -87,8 +84,8 @@ import           Linear.Metric import           Linear.Vector -import           GHC.Generics (Generic)-import           Data.Serialize (Serialize)+import           Data.Serialize     (Serialize)+import           GHC.Generics       (Generic)  ------------------------------------------------------------ --  Paths  -------------------------------------------------@@ -100,26 +97,12 @@ --   top of another) rather than concatenation. newtype Path v n = Path [Located (Trail v n)]   deriving (Semigroup, Monoid, Generic-#if __GLASGOW_HASKELL__ >= 707   , Typeable-#endif   )  -- 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)))) =>   Serialize (Path v n)--#if __GLASGOW_HASKELL__ < 707--- This should really be Typeable2 Path but since Path has kind---   (* -> *) -> * -> *--- not---   * -> * -> *--- we can only do Typeable1 (Path v). This is why the instance cannot be--- derived.-instance forall v. Typeable1 v => Typeable1 (Path v) where-  typeOf1 _ = mkTyConApp (mkTyCon3 "diagrams-lib" "Diagrams.Path" "Path") [] `mkAppTy`-              typeOf1 (undefined :: v n)-#endif  instance Wrapped (Path v n) where   type Unwrapped (Path v n) = [Located (Trail v n)]

@@ -371,7 +371,7 @@ --   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)-  deriving Show+  deriving (Eq, Ord, Show)  type instance V (FixedSegment v n) = v type instance N (FixedSegment v n) = n

@@ -1,8 +1,5 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP                        #-}-#if __GLASGOW_HASKELL__ >= 707+{-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE DeriveDataTypeable         #-}-#endif {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE FlexibleContexts           #-}@@ -46,18 +43,18 @@   ) where  import           Control.Applicative-import           Control.Lens        hiding (transform)+import           Control.Lens         hiding (transform) import           Control.Monad-import           Data.Foldable       as F+import           Data.Foldable        as F import           Data.Hashable-import           Data.Semigroup import           Data.Maybe+import           Data.Semigroup import           Data.Typeable-import           GHC.Generics        (Generic)+import           GHC.Generics         (Generic) import           Prelude -import           Diagrams.Core import           Diagrams.BoundingBox+import           Diagrams.Core  import           Linear.Affine import           Linear.Vector@@ -70,19 +67,11 @@ --   the dimensions. newtype SizeSpec v n = SizeSpec (v n)   deriving (-#if __GLASGOW_HASKELL__ >= 707   Typeable,-#endif   Functor,   Generic,   Hashable,   Show)--#if __GLASGOW_HASKELL__ < 707-instance forall v. Typeable1 v => Typeable1 (SizeSpec v) where-  typeOf1 _ = mkTyConApp (mkTyCon3 "diagrams-lib" "Diagrams.Size" "Size") [] `mkAppTy`-              typeOf1 (undefined :: v n)-#endif  type instance V (SizeSpec v n) = v type instance N (SizeSpec v n) = n

@@ -1,10 +1,9 @@-{-# LANGUAGE CPP                   #-} {-# LANGUAGE DeriveDataTypeable    #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE UndecidableInstances  #-}  -----------------------------------------------------------------------------@@ -50,23 +49,12 @@     , up      :: V3 n     , lens    :: l n     }-#if __GLASGOW_HASKELL__ >= 707   deriving Typeable-#else -instance forall l. Typeable1 l => Typeable1 (Camera l) where-  typeOf1 _ = mkTyConApp (mkTyCon3 "diagrams-lib" "Diagrams.ThreeD.Camera" "Camera") [] `mkAppTy`-              typeOf1 (undefined :: l n)-#endif- type instance V (Camera l n) = V3 type instance N (Camera l n) = n -#if __GLASGOW_HASKELL__ > 707 class Typeable l => CameraLens l where-#else-class Typeable1 l => CameraLens l where-#endif   -- | The natural aspect ratio of the projection.   aspect :: Floating n => l n -> n 

@@ -19,7 +19,7 @@ -- | The perspective division onto the plane z=1 along lines going --   through the origin. perspectiveZ1 :: (R3 v, Functor v, Fractional n) => Deformation v v n-perspectiveZ1 = Deformation $ \p -> p ^/ (p ^. _x)+perspectiveZ1 = Deformation $ \p -> p ^/ (p ^. _z)  facingZ :: (R3 v, Functor v, Fractional n) => Deformation v v n facingZ = Deformation $

@@ -1,5 +1,4 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DeriveDataTypeable    #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -41,10 +40,6 @@   , difference   ) where -#if __GLASGOW_HASKELL__ < 710-import           Control.Applicative-import           Data.Foldable             (foldMap)-#endif import           Control.Lens              (review, (^.), _1) import           Data.Typeable @@ -255,11 +250,11 @@ -- | The Envelope for an Intersection or Difference is simply the -- Envelope of the Union.  This is wrong but easy to implement. instance RealFloat n => Enveloped (CSG n) where-  getEnvelope (CsgEllipsoid p) = getEnvelope p-  getEnvelope (CsgBox p) = getEnvelope p-  getEnvelope (CsgFrustum p) = getEnvelope p-  getEnvelope (CsgUnion ps) = foldMap getEnvelope ps-  getEnvelope (CsgIntersection ps) = foldMap getEnvelope ps+  getEnvelope (CsgEllipsoid p)      = getEnvelope p+  getEnvelope (CsgBox p)            = getEnvelope p+  getEnvelope (CsgFrustum p)        = getEnvelope p+  getEnvelope (CsgUnion ps)         = foldMap getEnvelope ps+  getEnvelope (CsgIntersection ps)  = foldMap getEnvelope ps   getEnvelope (CsgDifference p1 p2) = getEnvelope p1 <> getEnvelope p2 -- TODO after implementing some approximation scheme, calculate -- correct (approximate) envelopes for intersections and difference.

@@ -112,7 +112,7 @@ 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@@ -221,60 +221,46 @@ instance (Metric v, OrderedField n, Real n)     => EndValues (SegTree v n) -type SplitResult v n = ((SegTree v n, n -> n), (SegTree v n, n -> n))--splitAtParam' :: (Metric v, OrderedField n, Real n) => SegTree v n -> n -> SplitResult v n-splitAtParam' tree@(SegTree t) p-  | p < 0     =-    case FT.viewl t of-      EmptyL    -> emptySplit-      seg FT.:< t' ->-        case seg `splitAtParam` (p * tSegs) of-          (seg1, seg2) ->-            ( (SegTree $ FT.singleton seg1, (*p))-            , (SegTree $ seg2 <| t', \u -> 1 - (1 - u) * tSegs / (tSegs + 1))-            )-  | p >= 1    =-    case FT.viewr t of-      EmptyR    -> emptySplit-      t' FT.:> seg ->-        case seg `splitAtParam` (1 - (1 - p)*tSegs) of-          (seg1, seg2) ->-            ( (SegTree $ t' |> seg1, \u -> u * tSegs / (tSegs + 1))-            , (SegTree $ FT.singleton seg2, \u -> (u - p) / (1 - p))-            )-  | otherwise =-    case FT.viewl after of-      EmptyL    -> emptySplit-      seg FT.:< after' ->-        let (n, p') = propFrac $ p * tSegs-            f p n u | u * tSegs < n = u * tSegs / (n + 1)-                    | otherwise     = (n + (u * tSegs - n) / (p * tSegs - n)) / (n+1)-        in case seg `splitAtParam` p' of-             (seg1, seg2) ->-               ( ( SegTree $ before |> seg1  , f p n )-               , ( SegTree $ seg2   <| after'-               , \v -> 1 - f (1 - p) (tSegs - n - 1) (1 - v)-                 )-               )- where-   (before, after) = FT.split ((p * tSegs <) . numSegs) t-   tSegs           = numSegs t-   emptySplit      = let t' = (tree, id) in (t',t')--   propFrac x = let m = signum x * mod1 x in (x - m, m)+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 = let ((a,_),(b,_)) = splitAtParam' tree p in (a,b)+  splitAtParam tree p = fst $ splitAtParam' tree p    reverseDomain (SegTree t) = SegTree $ FT.reverse t'     where t' = FT.fmap' reverseSegment t -  section x t1 t2 = let ((a,fa),_) = splitAtParam' x t2-                    in  snd $ splitAtParam a (fa t1)--  -- XXX seems like it should be possible to collapse some of the-  -- above cases into one?+  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@@ -520,6 +506,8 @@     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)@@ -767,6 +755,8 @@ --   '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 

@@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP             #-} {-# LANGUAGE MonoLocalBinds  #-} {-# LANGUAGE TypeFamilies    #-} 

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                        #-} {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DeriveDataTypeable    #-} {-# LANGUAGE FlexibleContexts      #-}@@ -27,9 +26,6 @@     where  import           Control.Lens            (makeLenses, view, (^.))-#if __GLASGOW_HASKELL__ < 710-import           Data.Semigroup-#endif import           Data.Typeable  import           Diagrams.Angle

@@ -240,7 +240,7 @@         , extrudeLeft, extrudeRight, extrudeBottom, extrudeTop -       , rectEnvelope+       , rectEnvelope, crop           -- ** Background 

@@ -1,7 +1,11 @@-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ConstraintKinds  #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ViewPatterns     #-} {-# LANGUAGE TypeFamilies     #-}+{-# LANGUAGE ViewPatterns     #-}++{-# OPTIONS_GHC -fno-warn-unused-imports #-}+  -- for Data.Semigroup+ ----------------------------------------------------------------------------- -- | -- Module      :  Diagrams.TwoD.Arc@@ -37,11 +41,11 @@ import           Diagrams.TrailLike import           Diagrams.TwoD.Transform import           Diagrams.TwoD.Types-import           Diagrams.TwoD.Vector    (unitX, unitY, unit_Y, e)+import           Diagrams.TwoD.Vector    (e, unitX, unitY, unit_Y) import           Diagrams.Util           (( # ))  import           Control.Lens            ((&), (<>~), (^.))-import           Data.Semigroup          ((<>))+import           Data.Semigroup  import           Linear.Affine import           Linear.Metric

@@ -1,5 +1,4 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP                        #-}+{-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -105,9 +104,6 @@        , module Diagrams.TwoD.Arrowheads        ) where -#if __GLASGOW_HASKELL__ < 710-import           Control.Applicative       ((<$>), (<*>))-#endif import           Control.Lens              (Lens', Traversal',                                             generateSignatures, lensRules,                                             makeLensesWith, view, (%~), (&),

@@ -1,5 +1,4 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP                        #-}+{-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE FlexibleContexts           #-}@@ -11,7 +10,6 @@ {-# LANGUAGE TemplateHaskell            #-} {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE UndecidableInstances       #-}-{-# LANGUAGE ViewPatterns               #-}  ----------------------------------------------------------------------------- -- |

@@ -1,8 +1,12 @@-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeFamilies          #-}++{-# OPTIONS_GHC -fno-warn-unused-imports #-}+  -- for Data.Semigroup+ ----------------------------------------------------------------------------- -- | -- Module      :  Diagrams.TwoD.Combinators@@ -32,7 +36,7 @@      , extrudeLeft, extrudeRight, extrudeBottom, extrudeTop -    , rectEnvelope+    , rectEnvelope, crop      , boundingRect, bg, bgFrame @@ -49,6 +53,7 @@ import           Diagrams.BoundingBox import           Diagrams.Combinators import           Diagrams.Path+import           Diagrams.Query           (value) import           Diagrams.Segment import           Diagrams.TrailLike import           Diagrams.TwoD.Align@@ -245,6 +250,11 @@      => Point V2 n -> V2 n -> QDiagram b V2 n m -> QDiagram b V2 n m rectEnvelope p (V2 w h) = withEnvelope (rect w h # alignBL # moveTo p :: Path V2 n) +-- | A synonym for 'rectEnvelope'.+crop :: forall b n m. (OrderedField n, Monoid' m)+     => Point V2 n -> V2 n -> QDiagram b V2 n m -> QDiagram b V2 n m+crop = rectEnvelope+ -- | Construct a bounding rectangle for an enveloped object, that is, --   the smallest axis-aligned rectangle which encloses the object. boundingRect :: ( InSpace V2 n a, SameSpace a t@@ -255,12 +265,15 @@  -- | \"Set the background color\" of a diagram.  That is, place a --   diagram atop a bounding rectangle of the given color.-bg :: (TypeableFloat n, Renderable (Path V2 n) b) => Colour Double -> QDiagram b V2 n Any -> QDiagram b V2 n Any-bg c d = d <> boundingRect d # lwO 0 # fc c+--   The background does not change the result of queries.+bg :: (TypeableFloat n, Renderable (Path V2 n) b, Monoid' q)+    => Colour Double -> QDiagram b V2 n q -> QDiagram b V2 n q+bg c d = d <> boundingRect d # lwO 0 # fc c # value mempty  -- | Similar to 'bg' but makes the colored background rectangle larger than --   the diagram. The first parameter is used to set how far the background --   extends beyond the diagram.-bgFrame :: (TypeableFloat n, Renderable (Path V2 n) b)-    => n -> Colour Double -> QDiagram b V2 n Any -> QDiagram b V2 n Any-bgFrame f c d = d <> boundingRect (frame f d) # lwO 0 # fc c+--   The background does not change the result of queries.+bgFrame :: (TypeableFloat n, Renderable (Path V2 n) b, Monoid' q)+    => n -> Colour Double -> QDiagram b V2 n q -> QDiagram b V2 n q+bgFrame f c d = d <> boundingRect (frame f d) # lwO 0 # fc c # value mempty

@@ -1,4 +1,4 @@-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DeriveDataTypeable    #-} {-# LANGUAGE EmptyDataDecls        #-} {-# LANGUAGE FlexibleContexts      #-}@@ -36,7 +36,6 @@     ) where  import           Codec.Picture-import           Codec.Picture.Types  (dynamicMap)  import           Data.Colour          (AlphaColour) import           Data.Semigroup@@ -45,10 +44,10 @@ import           Diagrams.Core  import           Diagrams.Attributes  (colorToSRGBA)-import           Diagrams.TwoD.Path   (isInsideEvenOdd) import           Diagrams.Path        (Path)+import           Diagrams.Query+import           Diagrams.TwoD.Path   (isInsideEvenOdd) import           Diagrams.TwoD.Shapes (rect)-import Diagrams.Query import           Diagrams.TwoD.Types  import           Data.ByteString

@@ -1,5 +1,4 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP       #-}+{-# LANGUAGE ConstraintKinds     #-} {-# LANGUAGE DeriveFunctor       #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -47,30 +46,27 @@      ) 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           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.Class-import           Data.List               (maximumBy, minimumBy)-import           Data.Maybe              (catMaybes)-#if __GLASGOW_HASKELL__ < 710-import           Data.Monoid             (mconcat, mempty)-#endif-import           Data.Ord                (comparing)+import           Data.List            (maximumBy, minimumBy)+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.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.TwoD.Vector (leftTurn, unitX, unitY, unit_Y)+import           Diagrams.Util        (tau, ( # ))  import           Linear.Affine import           Linear.Metric@@ -174,10 +170,10 @@             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+            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

@@ -169,6 +169,14 @@   go p q tmin tmax umin umax clip revCurves     | isNothing chopInterval = [] +    -- 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@@ -181,11 +189,6 @@            in  go ql p' umin umid tmin' tmax' clip' (not revCurves) ++                go qr p' umid umax tmin' tmax' clip' (not revCurves) -    | 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 ) ]-     -- iterate with the curves reversed.     | otherwise = go q p' umin umax tmin' tmax' clip' (not revCurves)     where@@ -281,11 +284,21 @@         | otherwise = continue        testAbove (p1@(P (V2 _ y1)) : p2@(P (V2 _ y2)) : ps)-        | y1 < y2   = Nothing-        | y2 > dmax = testAbove (p2:ps)-        | otherwise = Just $ intersectPt dmax p1 p2-      testAbove _   = Nothing+        | 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)@@ -297,28 +310,30 @@  -- Could split this into a separate module. --- | Returns @(a, b, c)@ such that @ax + by + c = 0@ is the line going through---   @p1@ and @p2@ with @a^2 + b^2 = 1@.-lineEquation :: Floating n => P2 n -> P2 n -> (n, n, n)-lineEquation (P (V2 x1 y1)) (P (V2 x2 y2)) = (a, b, c)+-- | Returns @(a, b, c, d)@ such that @ax + by + c = 0@ is the line going through+--   @p1@ and @p2@ with @(a^2)/d + (b^2)/d = 1@.  We delay the division by+--   @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-    a  = a' / d-    b  = b' / d-    c  = -(x1*a' + y1*b') / d-    a' = y1 - y2-    b' = x2 - x1-    d  = sqrt $ a'*a' + b'*b'+    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 :: Floating n => P2 n -> P2 n -> P2 n -> n-lineDistance p1 p2 (P (V2 x y)) = a*x + b*y + c-  where (a, b, c) = lineEquation p1 p2---- find the x value where the line through the two points--- intersect the line y=d-intersectPt :: OrderedField n => n -> P2 n -> P2 n -> n-intersectPt d (P (V2 x1 y1)) (P (V2 x2 y2)) =-  x1 + (d - y1) * (x2 - x1) / (y2 - y1)+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  -- clockwise :: (Num n, Ord n) => V2 n -> V2 n -> Bool -- clockwise a b = a `cross2` b <= 0@@ -346,6 +361,9 @@ 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) 

@@ -1,5 +1,4 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP                        #-}+{-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}@@ -58,9 +57,6 @@  import           Data.Colour              hiding (over) import           Data.Default.Class-#if __GLASGOW_HASKELL__ < 710-import           Data.Functor-#endif import           Data.Monoid.Recommend import           Data.Semigroup import           Data.Typeable

@@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}-+{-# LANGUAGE TypeFamilies     #-}  module Diagrams.Test.Trail where @@ -8,6 +8,9 @@ import           Test.Tasty import           Test.Tasty.QuickCheck +import           Data.Fixed+import           Data.List+ tests :: TestTree tests = testGroup "Trail"   [ let wrap :: Trail' Line V2 Double -> Located (Trail V2 Double)@@ -45,4 +48,66 @@     \t -> (reverseLocLoop . reverseLocLoop $ t) =~           (t :: Located (Trail' Loop V2 Double)) +  , testProperty "section on Trail' Line endpoints match paramaters" $+    \t (Param a) (Param b) ->+      let s = section (t :: Located (Trail' Line V2 Double)) a b+      in  t `atParam` a =~ s `atParam` 0 &&+          t `atParam` b =~ s `atParam` 1++  , testProperty "section on Trail' Line where a paramater is 0 or 1" $+    \t (Param a) ->+      let l = section (t :: Located (Trail' Line V2 Double)) 0 a+          r = section (t :: Located (Trail' Line V2 Double)) a 1+      in  t `atParam` 0 =~ l `atParam` 0 &&+          t `atParam` a =~ l `atParam` 1 &&+          t `atParam` a =~ r `atParam` 0 &&+          t `atParam` 1 =~ r `atParam` 1++  , testProperty "section on Trail' Line where a segment paramater is 0 or 1" $+    \t (Param a) i ->+      let st = unLoc t # \(Line st') -> st' :: SegTree V2 Double+          b | (numSegs st :: Word) > 0 = (fromIntegral (i `mod` (numSegs st + 1) :: Word)) / numSegs st+            | otherwise                = 0+          s = section (t :: Located (Trail' Line V2 Double)) a b+      in  t `atParam` a =~ s `atParam` 0 &&+          t `atParam` b =~ s `atParam` 1++  , testProperty "section on Trail' Line matches section on FixedSegment" $+    \t (Param a) (Param b) -> sectionTrailSectionFixedSegment t a b+   ]++data Param = Param Double deriving Show++instance Arbitrary Param where+  arbitrary = Param <$> choose (-0.5, 1.5)++sectionTrailSectionFixedSegment :: Located (Trail' Line V2 Double) -> Double -> Double -> Bool+sectionTrailSectionFixedSegment t k1 k2+  | null segs = t == t'+  | otherwise = aSecT =~ aSecFS && bSecT =~ bSecFS+  where+    a = min k1 k2+    b = max k1 k2+    t' = section t a b++    segs  = fixTrail $ mapLoc wrapLine t+    segs' = fixTrail $ mapLoc wrapLine t'++    aSecT = head segs'+    bSecT = last segs'++    (aSegIx, a') = splitParam a+    (bSegIx, b') = splitParam b++    aSecFS = section (segs !! floor aSegIx) a' x+      where x = if aSegIx == bSegIx then b' else 1+    bSecFS = section (segs !! floor bSegIx) x  b'+      where x = if aSegIx == bSegIx then a' else 0++    splitParam p | p <  0    = (0    , p           * n)+                 | p >= 1    = (n - 1, 1 + (p - 1) * n)+                 | otherwise = propFrac $  p       * n+      where+        propFrac x = let m = x `mod'` 1 in (x - m, m)+        n = genericLength segs

@@ -3,10 +3,11 @@ module Diagrams.Test.TwoD where  import           Diagrams.Prelude+import qualified Diagrams.Query as Query (sample) import           Diagrams.Trail        (linePoints) import           Instances import           Test.Tasty-import           Test.Tasty.QuickCheck+import           Test.Tasty.QuickCheck as QC  newtype SmallAngle = SmallAngle (Angle Double)   deriving (Eq, Ord, Show)@@ -50,4 +51,15 @@           , testProperty "lineSegments . fromSegments === id" $             \segs -> lineSegments (fromSegments segs) =~ (segs :: [Segment Closed V2 Double])           ]-      ]+    , testGroup "Queries and Backgrounds"+        (let dia :: QDiagram NullBackend V2 Double [Int]+             dia = circle 5 # scaleX 2 # rotateBy (1/14) # value [1]+                   <>+                   circle 2 # scaleX 5 # rotateBy (-4/14) # value [2]+         in [+           testProperty "sample dia pt === sample (dia # bg color) pt" $+           \pt -> Query.sample dia pt QC.=== Query.sample (dia # bg orange) pt+         , testProperty "sample dia pt === sample (dia # bgFrame 0.1 color) pt" $+           \pt -> Query.sample dia pt QC.=== Query.sample (dia # bgFrame 0.1 green) pt+         ])+    ]

@@ -0,0 +1,54 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Diagrams.Test.TwoD.Segment+    (+      tests+    ) where++import qualified Test.QuickCheck.Property as Q+import           Test.Tasty               (TestTree)+import           Test.Tasty.QuickCheck++import           Diagrams.Prelude+import           Diagrams.TwoD.Segment++newtype InBox = InBox { unInBox :: Double }++instance Arbitrary InBox where+  arbitrary = InBox <$> choose (-1, 1)++instance Arbitrary (Point V2 Double) where+  arbitrary = curry p2 <$> (unInBox <$> arbitrary)+                       <*> (unInBox <$> arbitrary)++instance Arbitrary (FixedSegment V2 Double) where+   arbitrary = oneof [FLinear <$> arbitrary <*> arbitrary, FCubic <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary]++epsT, epsE :: Double+epsT = 1.0e-9 -- parameter space epsilon+epsE = 1.0e-8 -- Euclidean space epsilon++(.=~.) :: P2 Double -> P2 Double -> Bool+x .=~. y = norm (x .-. y) < epsE++tests :: [TestTree]+tests =+    [ testProperty "segmentSegment" $+        \a b -> validateIntersections a b (segmentSegment epsT a b)+    ]++validateIntersections :: FixedSegment V2 Double -> FixedSegment V2 Double -> [(Double, Double, P2 Double)] -> Q.Result+validateIntersections _ _ [] = Q.rejected -- TODO: check for false negatives (rasterize both and look for overlap?)+validateIntersections a b isects = go isects+  where+    go [] = Q.succeeded+    go ((ta,tb,p):is)+      | and [ 0 <= ta && ta <= 1+            , 0 <= tb && tb <= 1+            , a `atParam` ta .=~. p+            , b `atParam` tb .=~. p+            ] = go is+      | otherwise = Q.failed

@@ -13,7 +13,7 @@  import           Diagrams.Prelude import           Numeric.Extras-import           Test.Tasty.QuickCheck (Arbitrary(..), Gen)+import           Test.Tasty.QuickCheck (Arbitrary (..), Gen) import qualified Test.Tasty.QuickCheck as QC  ------------------------------------------------------------@@ -56,6 +56,11 @@     _ =~ _ = False     -- The above is conservative:     -- Cubic never equals Linear even if they describe the same points++instance Approx n => Approx (FixedSegment V2 n) where+    FLinear a0 b0 =~ FLinear a1 b1 = a0 =~ a1 && b0 =~ b1+    FCubic a0 b0 c0 d0 =~ FCubic a1 b1 c1 d1 = a0 =~ a1 && b0 =~ b1 && c0 =~ c1 && d0 =~ d1+    _ =~ _ = False  instance Approx n => Approx (Trail' Line V2 n) where     l0 =~ l1 = and $ zipWith (=~) (lineSegments l0) (lineSegments l1)

@@ -1,17 +1,19 @@ import           Test.Tasty                (TestTree, defaultMain, testGroup) -import qualified Diagrams.Test.Angle       as Angle-import qualified Diagrams.Test.Direction   as Direction-import qualified Diagrams.Test.Transform   as Transform-import qualified Diagrams.Test.Transform.Matrix   as TransformMatrix-import qualified Diagrams.Test.TwoD        as TwoD-import qualified Diagrams.Test.TwoD.Offset as TwoD.Offset+import qualified Diagrams.Test.Angle            as Angle+import qualified Diagrams.Test.Direction        as Direction+import qualified Diagrams.Test.Transform        as Transform+import qualified Diagrams.Test.Transform.Matrix as TransformMatrix+import qualified Diagrams.Test.TwoD             as TwoD+import qualified Diagrams.Test.TwoD.Offset      as TwoD.Offset+import qualified Diagrams.Test.TwoD.Segment     as TwoD.Segment -import qualified Diagrams.Test.Trail       as Trail+import qualified Diagrams.Test.Trail            as Trail  tests :: TestTree tests = testGroup "unit tests"     [ testGroup "TwoD.Offset" TwoD.Offset.tests+    , testGroup "TwoD.Segment" TwoD.Segment.tests     , TwoD.tests     , Angle.tests     , Direction.tests