Merge pull request #72 from diagrams/new-stuff

New stuff

diagrams-core.cabal

@@ -30,20 +30,23 @@ Library
                        Diagrams.Core.Points,
                        Diagrams.Core.Query
                        Diagrams.Core.Style,
+                       Diagrams.Core.Measure,
                        Diagrams.Core.Trace,
                        Diagrams.Core.Transform,
                        Diagrams.Core.Types,
                        Diagrams.Core.V
 
   Build-depends:       base >= 4.2 && < 4.8,
                        containers >= 0.4.2 && < 0.6,
+                       unordered-containers >= 0.2 && < 0.2.6,
                        semigroups >= 0.8.4 && < 0.16,
                        monoid-extras >= 0.3 && < 0.4,
                        dual-tree >= 0.2 && < 0.3,
                        lens >= 4.0 && < 4.5,
                        linear >= 1.10 && < 1.11,
                        adjunctions >= 4.0 && < 5.0,
-                       distributive >=0.2.2 && < 1.0
+                       distributive >=0.2.2 && < 1.0,
+                       mtl
   hs-source-dirs:      src
 
   Other-extensions:    DeriveDataTypeable

src/Diagrams/Core.hs

@@ -92,7 +92,7 @@
 module Diagrams.Core
        ( -- * Associated vector spaces
 
-         V, N, Vn
+         V, N, Vn, InSpace, SameSpace
 
          -- * Points
 
@@ -148,11 +148,11 @@ module Diagrams.Core
          -- * Attributes and styles
 
        , AttributeClass
-       , Attribute, mkAttr, mkTAttr, mkGTAttr, unwrapAttr
+       , Attribute, mkAttr, mkTAttr, unwrapAttr
 
        , Style, HasStyle(..)
        , getAttr, combineAttr
-       , applyAttr, applyTAttr, applyGTAttr
+       , applyAttr, applyMAttr, applyTAttr
 
          -- * Envelopes
 
@@ -202,6 +202,7 @@ module Diagrams.Core
        , localize
 
        , href
+       , opacityGroup
 
        , setEnvelope, setTrace
 
@@ -214,14 +215,18 @@ module Diagrams.Core
        , location
        , subPoint
 
-         -- * Measurements
-       , Measure(..)
-       , fromMeasure
-       , fromOutput
-       , toOutput
-       , atMost
-       , atLeast
+         -- ** Measurements
+
+       , Measured
+       , Measure
+       , fromMeasured
+       , output
+       , local
+       , global
+       , normalized
        , scaleLocal
+       , atLeast
+       , atMost
 
          -- * Backends
 
@@ -238,9 +243,9 @@ module Diagrams.Core
          -- * Convenience classes
 
        , HasLinearMap
+       , HasBasis
        , OrderedField
        , TypeableFloat
-       , DataFloat
        , Monoid'
 
        ) where
@@ -256,6 +261,7 @@ import           Diagrams.Core.Style
 import           Diagrams.Core.Trace
 import           Diagrams.Core.Transform
 import           Diagrams.Core.Types
+import           Diagrams.Core.Measure
 import           Diagrams.Core.V
 
 import           Data.Monoid.WithSemigroup (Monoid')

src/Diagrams/Core/Compile.hs

@@ -31,8 +31,6 @@ module Diagrams.Core.Compile
 
   , toDTree
   , fromDTree
-  , styleToOutput
-  , toOutput
   )
   where
 
@@ -47,12 +45,11 @@ import           Data.Tree
 import           Data.Tree.DUAL
 
 import           Diagrams.Core.Envelope    (OrderedField, diameter)
-import           Diagrams.Core.Style
 import           Diagrams.Core.Transform
 import           Diagrams.Core.Types
+import           Diagrams.Core.Style
 
 import           Linear.Metric hiding (qd)
-import           Linear.Vector
 
 emptyDTree :: Tree (DNode b v n a)
 emptyDTree = Node DEmpty []
@@ -61,8 +58,7 @@ uncurry3 :: (a -> b -> c -> r) -> (a, b, c) -> r
 uncurry3 f (x, y, z) = f x y z
 
 -- | Convert a @QDiagram@ into a raw tree.
-toDTree :: (Additive v, Num n) => n -> n -> QDiagram b v n m
-                          -> Maybe (DTree b v n Annotation)
+toDTree :: (HasLinearMap v, Floating n, Typeable n) => n -> n -> QDiagram b v n m -> Maybe (DTree b v n Annotation)
 toDTree g n (QD qd)
   = foldDUAL
 
@@ -79,8 +75,7 @@ toDTree g n (QD qd)
                -- the continuation, convert the result to a DTree, and
                -- splice it in, adding a DDelay node to mark the point
                -- of the splice.
-               (Node DDelay . (:[]) . fromMaybe emptyDTree . toDTree g n
-                            . ($ (d, g, n)) . uncurry3)
+               (Node DDelay . (:[]) . fromMaybe emptyDTree . toDTree g n . ($ (d, g, n)) . uncurry3)
       )
 
       -- u-only leaves --> empty DTree. We don't care about the
@@ -112,7 +107,7 @@ toDTree g n (QD qd)
 -- | Convert a @DTree@ to an @RTree@ which can be used dirctly by backends.
 --   A @DTree@ includes nodes of type @DTransform (Transformation v)@;
 --   in the @RTree@ transform is pushed down until it reaches a primitive node.
-fromDTree :: forall b v n. (Num n, HasLinearMap v) => DTree b v n Annotation -> RTree b v n Annotation
+fromDTree :: forall b v n. (Floating n, HasLinearMap v) => DTree b v n Annotation -> RTree b v n Annotation
 fromDTree = fromDTree' mempty
   where
     fromDTree' :: HasLinearMap v => Transformation v n -> DTree b v n Annotation -> RTree b v n Annotation
@@ -158,7 +153,7 @@ toRTree
      , Typeable n, OrderedField n, Monoid m, Semigroup m)
   => Transformation v n -> QDiagram b v n m -> RTree b v n Annotation
 toRTree globalToOutput d
-  = (fmap . onRStyle) (styleToOutput gToO nToO)
+  = (fmap . onRStyle) (unmeasureAttrs gToO nToO)
   . fromDTree
   . fromMaybe (Node DEmpty [])
   . toDTree gToO nToO
@@ -170,39 +165,14 @@ toRTree globalToOutput d
     -- of product of diameters along each basis direction.  Note at
     -- this point the diagram has already had the globalToOutput
     -- transformation applied, so output = global = local units.
-    nToO = product (map (`diameter` d) basis) ** (1 / fromIntegral (dimension d))
+    nToO = product (map (`diameter` d) basis') ** (1 / fromIntegral (dimension d))
 
 -- | Apply a style transformation on 'RStyle' nodes; the identity for
 --   other 'RNode's.
 onRStyle :: (Style v n -> Style v n) -> RNode b v n a -> RNode b v n a
 onRStyle f (RStyle s) = RStyle (f s)
 onRStyle _ n          = n
 
--- | Convert all 'Measure' values to 'Output' units.  The arguments
---   are, respectively, the scaling factor from global units to output
---   units, and from normalized units to output units.  It is assumed
---   that local units are identical to output units (which will be the
---   case if all transformations have been fully pushed down and
---   applied). Normalized units are based on a logical diagram size of
---   1 x 1.
-styleToOutput
-  :: forall v n. (
-#if __GLASGOW_HASKELL__ > 707
-                   Typeable v
-#else
-                   Typeable1 v
-#endif
-                 , Typeable n, Fractional n, Ord n)
-  => n -> n -> Style v n -> Style v n
-styleToOutput globalToOutput normToOutput =
-  gmapAttrs (toOutput globalToOutput normToOutput :: Measure n -> Measure n)
-
--- | Convert an arbitrary 'Measure' to 'Output' units using the given global and 
---   normalized scales.
-toOutput :: (Num n, Ord n)
-  => n -> n -> Measure n -> Measure n
-toOutput g n = Output . fromMeasure g n
-
 --------------------------------------------------
 
 -- | Render a diagram, returning also the transformation which was
@@ -211,8 +181,7 @@ toOutput g n = Output . fromMeasure g n
 --   transformation can be used, for example, to convert output/screen
 --   coordinates back into diagram coordinates.  See also 'adjustDia'.
 renderDiaT
-  :: ( Backend b v n
-     , HasLinearMap v, Metric v
+  :: ( Backend b v n , HasLinearMap v, Metric v
 #if __GLASGOW_HASKELL__ > 707
      , Typeable v
 #else
@@ -228,8 +197,7 @@ renderDiaT b opts d = (g2o, renderRTree b opts' . toRTree g2o $ d')
 
 -- | Render a diagram.
 renderDia
-  :: ( Backend b v n
-     , HasLinearMap v, Metric v
+  :: ( Backend b v n , HasLinearMap v, Metric v
 #if __GLASGOW_HASKELL__ > 707
      , Typeable v
 #else

src/Diagrams/Core/Envelope.hs

@@ -151,7 +151,7 @@ instance Show (Envelope v n) where
 --  Transforming envelopes  --------------------------------
 ------------------------------------------------------------
 
-instance (Additive v, Metric v, Floating n) => Transformable (Envelope v n) where
+instance (Metric v, Floating n) => Transformable (Envelope v n) where
   transform t = moveOriginTo (P . negated . transl $ t) . onEnvelope g
     where
       -- XXX add lots of comments explaining this!

src/Diagrams/Core/HasOrigin.hs

@@ -26,6 +26,7 @@ module Diagrams.Core.HasOrigin
 import qualified Data.Map             as M
 import qualified Data.Set             as S
 
+import           Diagrams.Core.Measure
 import           Diagrams.Core.Points ()
 import           Diagrams.Core.V
 
@@ -84,6 +85,9 @@ moveTo = moveOriginBy . (origin .-.)
 place :: (V t ~ v, N t ~ n, Additive v, Num n, HasOrigin t) => t -> Point v n -> t
 place = flip moveTo
 
+instance HasOrigin t => HasOrigin (Measured n t) where
+  moveOriginTo = fmap . moveOriginTo
+
 instance (Additive v, Num n) => HasOrigin (Point v n) where
   moveOriginTo (P u) p = p .-^ u
 

src/Diagrams/Core/Juxtapose.hs

@@ -19,11 +19,12 @@ module Diagrams.Core.Juxtapose
        ( Juxtaposable(..), juxtaposeDefault
        ) where
 
-import           Data.Functor            ((<$>))
+import           Control.Applicative
 import qualified Data.Map                as M
 import qualified Data.Set                as S
 
 import           Diagrams.Core.Envelope
+import           Diagrams.Core.Measure
 import           Diagrams.Core.HasOrigin
 import           Diagrams.Core.V
 
@@ -72,3 +73,6 @@ instance (Enveloped b, HasOrigin b, Ord b) => Juxtaposable (S.Set b) where
 instance Juxtaposable a => Juxtaposable (b -> a) where
   juxtapose v f1 f2 b = juxtapose v (f1 b) (f2 b)
 
+instance Juxtaposable a => Juxtaposable (Measured n a) where
+  juxtapose v = liftA2 (juxtapose v)
+

src/Diagrams/Core/Measure.hs

@@ -0,0 +1,125 @@
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Diagrams.Core.Measure
+  ( Measured (..)
+  , Measure
+  , fromMeasured
+  , output
+  , local
+  , global
+  , normalized
+  , normalised
+  , scaleLocal
+  , atLeast
+  , atMost
+  ) where
+
+import           Control.Applicative
+import           Control.Lens
+import qualified Control.Monad.Reader as R
+import           Data.Distributive
+import           Data.Typeable
+import           Data.Semigroup
+
+import Diagrams.Core.V
+
+import           Linear.Vector
+
+-- (local, global, normalized) -> output
+newtype Measured n a = Measured { unmeasure :: (n,n,n) -> a }
+  deriving (Typeable, Functor, Applicative, Monad, Additive, R.MonadReader (n,n,n))
+
+type instance V (Measured n a) = V a
+type instance N (Measured n a) = N a
+
+type Measure n = Measured n n
+
+-- | @fromMeasured globalScale normalizedScale measure -> a@
+fromMeasured :: Num n => n -> n -> Measured n a -> a
+fromMeasured g n (Measured m) = m (1,g,n)
+
+-- | Output units don't change.
+output :: Num n => n -> Measure n
+output = pure
+
+-- | Local units are scaled by the average scale of a transform.
+local :: Num n => n -> Measure n
+local x = views _1 (*x)
+
+-- | Global units are ?
+global :: Num n => n -> Measure n
+global x = views _2 (*x)
+
+-- | Normalized units get scaled so that one normalized unit is the size of the 
+--   final diagram.
+normalized :: Num n => n -> Measure n
+normalized x = views _3 (*x)
+
+-- | Just like 'normalized' but spelt properly.
+normalised :: Num n => n -> Measure n
+normalised x = views _3 (*x)
+
+-- | Scale the local units of a 'Measured' thing.
+scaleLocal :: Num n => n -> Measured n a -> Measured n a
+scaleLocal s = R.local (_1 *~ s)
+
+-- | Calculate the smaller of two measures.
+atLeast :: Ord n => Measure n -> Measure n -> Measure n
+atLeast = liftA2 min
+
+-- | Calculate the larger of two measures.
+atMost :: Ord n => Measure n -> Measure n -> Measure n
+atMost = liftA2 max
+
+instance Num a => Num (Measured n a) where
+  (+) = (^+^)
+  (-) = (^-^)
+  (*) = liftA2 (*)
+
+  fromInteger = pure . fromInteger
+  abs         = fmap abs
+  signum      = fmap signum
+
+instance Fractional a => Fractional (Measured n a) where
+  (/)   = liftA2 (/)
+  recip = fmap recip
+
+  fromRational = pure . fromRational
+
+instance Floating a => Floating (Measured n a) where
+  pi      = pure pi
+  exp     = fmap exp
+  sqrt    = fmap sqrt
+  log     = fmap log
+  (**)    = liftA2 (**)
+  logBase = liftA2 logBase
+  sin     = fmap sin
+  tan     = fmap tan
+  cos     = fmap cos
+  asin    = fmap asin
+  atan    = fmap atan
+  acos    = fmap acos
+  sinh    = fmap sinh
+  tanh    = fmap tanh
+  cosh    = fmap cosh
+  asinh   = fmap asinh
+  atanh   = fmap atanh
+  acosh   = fmap acosh
+
+instance Semigroup a => Semigroup (Measured n a) where
+  (<>) = liftA2 (<>)
+
+instance Monoid a => Monoid (Measured n a) where
+  mempty  = pure mempty
+  mappend = liftA2 mappend
+
+
+instance Distributive (Measured n) where
+  distribute a = Measured $ \x -> fmap (\(Measured m) -> m x) a
+
+instance Profunctor Measured where
+  lmap f (Measured m) = Measured $ \(l,g,n) -> m (f l, f g, f n)
+  rmap f (Measured m) = Measured $ f . m
+