Merge pull request #218 from diagrams/new-stuff

New stuff

.travis.yml

@@ -10,7 +10,7 @@ env:
     - GHCVER=head
   global:
     - CABALVER=1.20
-    - HEAD_DEPS="diagrams-core"
+    - HEAD_DEPS="diagrams-core active"
 
 matrix:
   allow_failures:

diagrams-lib.cabal

@@ -28,8 +28,11 @@ Library
   Exposed-modules:     Diagrams.Prelude,
                        Diagrams.Align,
                        Diagrams.Angle,
+                       Diagrams.Animation,
+                       Diagrams.Animation.Active,
                        Diagrams.Attributes,
                        Diagrams.Attributes.Compile,
+                       Diagrams.Backend.CmdLine,
                        Diagrams.BoundingBox,
                        Diagrams.Combinators,
                        Diagrams.Coordinates,
@@ -46,12 +49,25 @@ Library
                        Diagrams.Points,
                        Diagrams.Query,
                        Diagrams.Segment,
+                       Diagrams.Size,
                        Diagrams.Solve,
                        Diagrams.Tangent,
+                       Diagrams.ThreeD,
+                       Diagrams.ThreeD.Align,
+                       Diagrams.ThreeD.Attributes,
+                       Diagrams.ThreeD.Camera,
+                       Diagrams.ThreeD.Deform,
+                       Diagrams.ThreeD.Light,
+                       Diagrams.ThreeD.Shapes,
+                       Diagrams.ThreeD.Size,
+                       Diagrams.ThreeD.Transform,
+                       Diagrams.ThreeD.Types,
+                       Diagrams.ThreeD.Vector,
                        Diagrams.Trace,
                        Diagrams.Trail,
                        Diagrams.TrailLike,
                        Diagrams.Transform,
+                       Diagrams.Transform.ScaleInv,
                        Diagrams.TwoD,
                        Diagrams.TwoD.Adjust,
                        Diagrams.TwoD.Align,
@@ -69,27 +85,13 @@ Library
                        Diagrams.TwoD.Path,
                        Diagrams.TwoD.Polygons,
                        Diagrams.TwoD.Segment,
-                       Diagrams.TwoD.Shapes,
                        Diagrams.TwoD.Size,
+                       Diagrams.TwoD.Shapes,
                        Diagrams.TwoD.Text,
                        Diagrams.TwoD.Transform,
-                       Diagrams.TwoD.Transform.ScaleInv,
                        Diagrams.TwoD.Types,
                        Diagrams.TwoD.Vector,
-                       Diagrams.ThreeD,
-                       Diagrams.ThreeD.Align,
-                       Diagrams.ThreeD.Attributes,
-                       Diagrams.ThreeD.Camera,
-                       Diagrams.ThreeD.Deform,
-                       Diagrams.ThreeD.Light,
-                       Diagrams.ThreeD.Shapes,
-                       Diagrams.ThreeD.Transform,
-                       Diagrams.ThreeD.Types,
-                       Diagrams.ThreeD.Vector,
-                       Diagrams.Animation,
-                       Diagrams.Animation.Active,
-                       Diagrams.Util,
-                       Diagrams.Backend.CmdLine
+                       Diagrams.Util
   Build-depends:       base >= 4.2 && < 4.8,
                        containers >= 0.3 && < 0.6,
                        array >= 0.3 && < 0.6,
@@ -114,8 +116,10 @@ Library
                        process >= 1.1 && < 1.3,
                        fsnotify >= 0.1 && < 0.2,
                        directory >= 1.2 && < 1.3,
+                       unordered-containers >= 0.2 && < 0.2.6,
                        system-filepath >= 0.2 && < 0.5,
-                       text >= 0.7.1 && < 1.3
+                       text >= 0.7.1 && < 1.3,
+                       mtl >= 2.0 && < 2.3
   if impl(ghc < 7.6)
     Build-depends: ghc-prim
   Hs-source-dirs:      src

src/Diagrams/Align.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds      #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -36,10 +37,12 @@ module Diagrams.Align
        ) where
 
 import           Diagrams.Core
+import           Diagrams.Core.Transform
 import           Diagrams.Util (applyAll)
 
 import           Data.Maybe    (fromMaybe)
 import           Data.Ord      (comparing)
+import           Data.Traversable
 
 import qualified Data.Foldable as F
 import qualified Data.Map      as M
@@ -58,19 +61,19 @@ class Alignable a where
   --   edge of the boundary in the direction of the negation of @v@.
   --   Other values of @d@ interpolate linearly (so for example, @d =
   --   0@ centers the origin along the direction of @v@).
-  alignBy' :: (V a ~ v, N a ~ n, HasOrigin a, Additive v, Fractional n)
+  alignBy' :: (InSpace v n a, Fractional n, HasOrigin a)
            => (v n -> a -> Point v n) -> v n -> n -> a -> a
   alignBy' = alignBy'Default
 
   defaultBoundary :: (V a ~ v, N a ~ n) => v n -> a -> Point v n
 
-  alignBy :: (V a ~ v, N a ~ n, Additive v, HasOrigin a, Fractional n)
+  alignBy :: (InSpace v n a, Fractional n, HasOrigin a)
           => v n -> n -> a -> a
   alignBy = alignBy' defaultBoundary
 
 -- | Default implementation of 'alignBy' for types with 'HasOrigin'
 --   and 'AdditiveGroup' instances.
-alignBy'Default :: (V a ~ v, N a ~ n, HasOrigin a, Additive v, Fractional n)
+alignBy'Default :: (InSpace v n a, Fractional n, HasOrigin a)
                 => (v n -> a -> Point v n) -> v n -> n -> a -> a
 alignBy'Default boundary v d a = moveOriginTo (lerp ((d + 1) / 2)
                                                     (boundary v a)
@@ -88,7 +91,7 @@ traceBoundary :: (V a ~ v, N a ~ n, Num n, Traced a) => v n -> a -> Point v n
 traceBoundary v a = fromMaybe origin (maxTraceP origin v a)
 
 combineBoundaries
-  :: (V a ~ v, N a ~ n, F.Foldable f, Metric v, Ord n, Num n)
+  :: (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
@@ -102,15 +105,15 @@ instance (Metric v, OrderedField n) => Alignable (Trace v n) where
 instance (V b ~ v, N b ~ n, Metric v, OrderedField n, Alignable b) => Alignable [b] where
   defaultBoundary = combineBoundaries defaultBoundary
 
-instance (V b ~ v, N b ~ n,  Metric v, OrderedField n, Alignable b)
+instance (V b ~ v, N b ~ n, Metric v, OrderedField n, Alignable b)
     => Alignable (S.Set b) where
   defaultBoundary = combineBoundaries defaultBoundary
 
-instance (V b ~ v, N b ~ n,  Metric v, OrderedField n, Alignable b)
+instance (V b ~ v, N b ~ n, Metric v, OrderedField n, Alignable b)
     => Alignable (M.Map k b) where
   defaultBoundary = combineBoundaries defaultBoundary
 
-instance (HasLinearMap v, Metric v, OrderedField n, Monoid' m)
+instance (Metric v, OrderedField n, Monoid' m)
     => Alignable (QDiagram b v n m) where
   defaultBoundary = envelopeBoundary
 
@@ -119,7 +122,7 @@ instance (HasLinearMap v, Metric v, OrderedField n, Monoid' m)
 --   'defaultBoundary'. Instead, we provide a total method, but one that
 --   is not sensible. This should not present a serious problem as long
 --   as your use of 'Alignable' happens through 'alignBy'.
-instance (V a ~ v, N a ~ n, Additive v, Num n, HasOrigin a, Alignable a) => Alignable (b -> a) where
+instance (InSpace v n a, HasOrigin a, Alignable a) => Alignable (b -> a) where
   alignBy v d f b     = alignBy v d (f b)
   defaultBoundary _ _ = origin
 
@@ -128,42 +131,42 @@ instance (V a ~ v, N a ~ n, Additive v, Num n, HasOrigin a, Alignable a) => Alig
 --   direction of @v@ until it is on the edge of the envelope.  (Note
 --   that if the local origin is outside the envelope to begin with,
 --   it may have to move \"backwards\".)
-align :: (V a ~ v, N a ~ n, Additive v, Alignable a, HasOrigin a, Fractional n) => v n -> a -> a
+align :: (InSpace v n a, Fractional n, Alignable a, HasOrigin a) => v n -> a -> a
 align v = alignBy v 1
 
 -- | Version of @alignBy@ specialized to use @traceBoundary@
-snugBy :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, Fractional n)
+snugBy :: (InSpace v n a, Fractional n, Alignable a, Traced a, HasOrigin a)
        => v n -> n -> a -> a
 snugBy = alignBy' traceBoundary
 
 -- | Like align but uses trace.
-snug :: (V a ~ v, N a ~ n, Fractional n, Alignable a, Traced a, HasOrigin a)
+snug :: (InSpace v n a, Fractional n, Alignable a, Traced a, HasOrigin a)
       => v n -> a -> a
 snug v = snugBy v 1
 
 -- | @centerV v@ centers an enveloped object along the direction of
 --   @v@.
-centerV :: (V a ~ v, N a ~ n, Additive v, Alignable a, HasOrigin a, Fractional n) => v n -> a -> a
+centerV :: (InSpace v n a, Fractional n, Alignable a, HasOrigin a) => v n -> a -> a
 centerV v = alignBy v 0
 
 -- | @center@ centers an enveloped object along all of its basis vectors.
-center :: (V a ~ v, N a ~ n, HasLinearMap v, Alignable a, HasOrigin a, Fractional n) => a -> a
+center :: (InSpace v n a, Fractional n, Traversable v, Alignable a, HasOrigin a) => a -> a
 center = applyAll fs
   where
-    fs = map centerV basis
+    fs = map centerV basis'
 
 -- | Like @centerV@ using trace.
 snugCenterV
-  :: (V a ~ v, N a ~ n, Fractional n, Alignable a, Traced a, HasOrigin a)
+  :: (InSpace v n a, Fractional n, Alignable a, Traced a, HasOrigin a)
    => v n -> a -> a
 snugCenterV v = alignBy' traceBoundary v 0
 
 -- | Like @center@ using trace.
-snugCenter :: (V a ~ v, N a ~ n, HasLinearMap v, Alignable a, HasOrigin a, Fractional n, Traced a)
+snugCenter :: (InSpace v n a, Traversable v, Fractional n, Alignable a, HasOrigin a, Traced a)
            => a -> a
 snugCenter = applyAll fs
   where
-    fs = map snugCenterV basis
+    fs = map snugCenterV basis'
 
 {-# ANN module ("HLint: ignore Use camelCase" :: String) #-}
 

src/Diagrams/Angle.hs

@@ -25,7 +25,7 @@ module Diagrams.Angle
 
          -- ** Trigonometric functions
        , sinA, cosA, tanA
-       , asinA, acosA, atanA, atan2A
+       , asinA, acosA, atanA, atan2A, atan2A'
 
          -- ** Angle utilities
        , angleBetween, angleRatio
@@ -41,6 +41,7 @@ import           Data.Monoid         hiding ((<>))
 import           Data.Semigroup
 
 import           Diagrams.Core.V
+import           Diagrams.Core       (OrderedField)
 import           Diagrams.Points
 
 import           Linear.Metric
@@ -49,7 +50,7 @@ import           Linear.Vector
 -- | Angles can be expressed in a variety of units.  Internally,
 --   they are represented in radians.
 newtype Angle n = Radians n
-  deriving (Read, Show, Eq, Ord, Enum,  Functor)
+  deriving (Read, Show, Eq, Ord, Enum, Functor)
 
 type instance N (Angle n) = n
 
@@ -131,11 +132,28 @@ acosA = Radians . acos
 atanA :: Floating n => n -> Angle n
 atanA = Radians . atan
 
--- | @atan2A y x@ is the angle between the positive x-axis and the vector given 
+-- | @atan2A y x@ is the angle between the positive x-axis and the vector given
 --   by the coordinates (x, y). The 'Angle' returned is in the [-pi,pi] range.
 atan2A :: RealFloat n => n -> n -> Angle n
 atan2A y x = Radians $ atan2 y x
 
+-- | Similar to 'atan2A' but without the 'RealFloat' constraint. This means it
+--   doesn't handle negative zero cases. However, for most geometric purposes,
+--   outcome will be the same.
+atan2A' :: OrderedField n => n -> n -> Angle n
+atan2A' y x = atan2' y x @@ rad
+
+-- atan2 without negative zero tests
+atan2' :: OrderedField n => n -> n -> n
+atan2' y x
+  | x > 0            =  atan (y/x)
+  | x == 0 && y > 0  =  pi/2
+  | x <  0 && y > 0  =  pi + atan (y/x)
+  | x <= 0 && y < 0  = -atan2' (-y) x
+  | y == 0 && x < 0  =  pi    -- must be after the previous test on zero y
+  | x==0 && y==0     =  y     -- must be after the other double zero tests
+  | otherwise        =  x + y -- x or y is a NaN, return a NaN (via +)
+
 -- | @30 \@\@ deg@ is an @Angle@ of the given measure and units.
 --
 --   More generally, @\@\@@ reverses the @Iso\'@ on its right, and
@@ -148,8 +166,9 @@ a @@ i = review i a
 infixl 5 @@
 
 -- | Compute the positive angle between the two vectors in their common plane.
+--   Returns NaN if either of the vectors are zero.
 angleBetween  :: (Metric v, Floating n) => v n -> v n -> Angle n
-angleBetween v1 v2 = acos (signorm v1 `dot` signorm v2) @@ rad
+angleBetween v1 v2 = acosA (signorm v1 `dot` signorm v2)
 -- N.B.: Currently discards the common plane information.
 
 -- | Normalize an angle so that it lies in the [0,tau) range.

src/Diagrams/Animation.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies          #-}
@@ -90,15 +91,15 @@ type Animation b v n = QAnimation b v n Any
 --
 --   See also 'animRect' for help constructing a background to go
 --   behind an animation.
-animEnvelope :: (Backend b v n, OrderedField n, Metric v, HasLinearMap v, Monoid' m)
+animEnvelope :: (Backend b v n, OrderedField n, Metric v, Monoid' m)
            => QAnimation b v n m -> QAnimation b v n m
 animEnvelope = animEnvelope' 30
 
 -- | Like 'animEnvelope', but with an adjustible sample rate.  The first
 --   parameter is the number of samples per time unit to use.  Lower
 --   rates will be faster but less accurate; higher rates are more
 --   accurate but slower.
-animEnvelope' :: (Backend b v n, OrderedField n, Metric v, HasLinearMap v, Monoid' m)
+animEnvelope' :: (Backend b v n, OrderedField n, Metric v, Monoid' m)
             => Rational -> QAnimation b v n m -> QAnimation b v n m
 animEnvelope' r a = withEnvelope (simulate r a) <$> a
 
@@ -109,15 +110,15 @@ animEnvelope' r a = withEnvelope (simulate r a) <$> a
 --
 --   Uses 30 samples per time unit by default; to adjust this number
 --   see 'animRect''.
-animRect :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ V2, N t ~ n, RealFloat n, Monoid' m)
+animRect :: (InSpace V2 n t, Num n, Monoid' m, TrailLike t, Enveloped t, Transformable t, Monoid t)
          => QAnimation b V2 n m -> t
 animRect = animRect' 30
 
 -- | Like 'animRect', but with an adjustible sample rate.  The first
 --   parameter is the number of samples per time unit to use.  Lower
 --   rates will be faster but less accurate; higher rates are more
 --   accurate but slower.
-animRect' :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ V2, N t ~ n, RealFloat n, Monoid' m)
+animRect' :: (InSpace V2 n t, Num n, Monoid' m, TrailLike t, Enveloped t, Transformable t, Monoid t)
           => Rational -> QAnimation b V2 n m -> t
 animRect' r anim
     | null results = rect 1 1