diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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)) 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.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, - . -Homepage: http://projects.haskell.org/diagrams + . +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, diff --git a/src/Diagrams/Align.hs b/src/Diagrams/Align.hs --- a/src/Diagrams/Align.hs +++ b/src/Diagrams/Align.hs @@ -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 diff --git a/src/Diagrams/Animation.hs b/src/Diagrams/Animation.hs --- a/src/Diagrams/Animation.hs +++ b/src/Diagrams/Animation.hs @@ -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 diff --git a/src/Diagrams/Animation/Active.hs b/src/Diagrams/Animation/Active.hs --- a/src/Diagrams/Animation/Active.hs +++ b/src/Diagrams/Animation/Active.hs @@ -1,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 diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -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 (..)) diff --git a/src/Diagrams/Attributes/Compile.hs b/src/Diagrams/Attributes/Compile.hs --- a/src/Diagrams/Attributes/Compile.hs +++ b/src/Diagrams/Attributes/Compile.hs @@ -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 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,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 diff --git a/src/Diagrams/Located.hs b/src/Diagrams/Located.hs --- a/src/Diagrams/Located.hs +++ b/src/Diagrams/Located.hs @@ -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 diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -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)] diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -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 diff --git a/src/Diagrams/Size.hs b/src/Diagrams/Size.hs --- a/src/Diagrams/Size.hs +++ b/src/Diagrams/Size.hs @@ -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 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 @@ -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 diff --git a/src/Diagrams/ThreeD/Deform.hs b/src/Diagrams/ThreeD/Deform.hs --- a/src/Diagrams/ThreeD/Deform.hs +++ b/src/Diagrams/ThreeD/Deform.hs @@ -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 $ 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 @@ -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. diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -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 diff --git a/src/Diagrams/Transform/Matrix.hs b/src/Diagrams/Transform/Matrix.hs --- a/src/Diagrams/Transform/Matrix.hs +++ b/src/Diagrams/Transform/Matrix.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE TypeFamilies #-} 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 @@ -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 diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -240,7 +240,7 @@ , extrudeLeft, extrudeRight, extrudeBottom, extrudeTop - , rectEnvelope + , rectEnvelope, crop -- ** Background diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -1,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 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,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, (%~), (&), 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,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 #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -1,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 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,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 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,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 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 @@ -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) 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,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 diff --git a/test/Diagrams/Test/Trail.hs b/test/Diagrams/Test/Trail.hs --- a/test/Diagrams/Test/Trail.hs +++ b/test/Diagrams/Test/Trail.hs @@ -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 diff --git a/test/Diagrams/Test/TwoD.hs b/test/Diagrams/Test/TwoD.hs --- a/test/Diagrams/Test/TwoD.hs +++ b/test/Diagrams/Test/TwoD.hs @@ -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 + ]) + ] diff --git a/test/Diagrams/Test/TwoD/Segment.hs b/test/Diagrams/Test/TwoD/Segment.hs new file mode 100644 --- /dev/null +++ b/test/Diagrams/Test/TwoD/Segment.hs @@ -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 diff --git a/test/Instances.hs b/test/Instances.hs --- a/test/Instances.hs +++ b/test/Instances.hs @@ -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) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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