Manual merge of fix point and linear/new-stuff

diagrams-core.cabal

@@ -23,6 +23,7 @@ Source-repository head
 Library
   Exposed-modules:     Diagrams.Core,
                        Diagrams.Core.Compile,
+                       Diagrams.Core.Context,
                        Diagrams.Core.Envelope,
                        Diagrams.Core.HasOrigin,
                        Diagrams.Core.Juxtapose,

src/Diagrams/Core.hs

@@ -141,7 +141,6 @@ module Diagrams.Core
 
        , SubMap(..)
        , fromNames
-       , rememberAs
 
        , lookupSub
 
@@ -192,15 +191,9 @@ module Diagrams.Core
          -- * Diagrams
 
        , QDiagram, Diagram, mkQD, pointDiagram
-       , envelope, trace, subMap, names, query, sample
+       , envelope, trace, query, sample
        , value, resetValue, clearValue
 
-       , nameSub
-       , withName
-       , withNameAll
-       , withNames
-       , localize
-
        , href
        , opacityGroup
 
@@ -211,8 +204,6 @@ module Diagrams.Core
          -- ** Subdiagrams
 
        , Subdiagram(..), mkSubdiagram
-       , getSub, rawSub
-       , location
        , subPoint
 
          -- ** Measurements

src/Diagrams/Core/Compile.hs

@@ -20,17 +20,11 @@ module Diagrams.Core.Compile
   ( -- * Tools for backends
     RNode(..)
   , RTree
-  , toRTree
 
     -- * Backend API
 
   , renderDia
   , renderDiaT
-
-    -- * Internals
-
-  , toDTree
-  , fromDTree
   )
   where
 
@@ -42,101 +36,21 @@ import           Data.Monoid.MList
 import           Data.Monoid.WithSemigroup (Monoid')
 import           Data.Semigroup
 import           Data.Tree
-import           Data.Tree.DUAL
 
+import           Diagrams.Core.Context
 import           Diagrams.Core.Envelope    (OrderedField, diameter)
 import           Diagrams.Core.Transform
 import           Diagrams.Core.Types
 import           Diagrams.Core.Style
 
 import           Linear.Metric hiding (qd)
 
-emptyDTree :: Tree (DNode b v n a)
-emptyDTree = Node DEmpty []
-
-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 :: (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
-
-      -- Prims at the leaves.  We ignore the accumulated d-annotations
-      -- for prims (since we instead distribute them incrementally
-      -- throughout the tree as they occur), or pass them to the
-      -- continuation in the case of a delayed node.
-      (\d -> withQDiaLeaf
-
-               -- Prim: make a leaf node
-               (\p -> Node (DPrim p) [])
-
-               -- Delayed tree: pass the accumulated d-annotations to
-               -- 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)
-      )
-
-      -- u-only leaves --> empty DTree. We don't care about the
-      -- u-annotations.
-      emptyDTree
-
-      -- a non-empty list of child trees.
-      (\ts -> case NEL.toList ts of
-                [t] -> t
-                ts' -> Node DEmpty ts'
-      )
-
-      -- Internal d-annotations.  We untangle the interleaved
-      -- transformations and style, and carefully place the style
-      -- /above/ the transform in the tree (since by calling
-      -- 'untangle' we have already performed the action of the
-      -- transform on the style).
-      (\d t -> case get d of
-                 Option Nothing   -> t
-                 Option (Just d') ->
-                   let (tr,sty) = untangle d'
-                   in  Node (DStyle sty) [Node (DTransform tr) [t]]
-      )
-
-      -- Internal a-annotations.
-      (\a t -> Node (DAnnot a) [t])
-      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. (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
-    -- We put the accumulated transformation (accTr) and the prim
-    -- into an RPrim node.
-    fromDTree' accTr (Node (DPrim p) _)
-      = Node (RPrim (transform accTr p)) []
-
-    -- Styles are transformed then stored in their own node
-    -- and accTr is push down the tree.
-    fromDTree' accTr (Node (DStyle s) ts)
-      = Node (RStyle (transform accTr s)) (fmap (fromDTree' accTr) ts)
-
-    -- Transformations are accumulated and pushed down as well.
-    fromDTree' accTr (Node (DTransform tr) ts)
-      = Node REmpty (fmap (fromDTree' (accTr <> tr)) ts)
 
-    fromDTree' accTr (Node (DAnnot a) ts)
-      = Node (RAnnot a) (fmap (fromDTree' accTr) ts)
-
-    -- Drop accumulated transformations upon encountering a DDelay
-    -- node --- the tree unfolded beneath it already took into account
-    -- any transformation at this point.
-    fromDTree' _ (Node DDelay ts)
-      = Node REmpty (fmap (fromDTree' mempty) ts)
-
-    -- DEmpty nodes become REmpties, again accTr flows through.
-    fromDTree' accTr (Node _ ts)
-      = Node REmpty (fmap (fromDTree' accTr) ts)
+-- | 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
 
 -- | Compile a @QDiagram@ into an 'RTree', rewriting styles with the
 --   given function along the way.  Suitable for use by backends when
@@ -152,26 +66,11 @@ toRTree
 #endif
      , 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) (unmeasureAttrs gToO nToO)
-  . fromDTree
-  . fromMaybe (Node DEmpty [])
-  . toDTree gToO nToO
-  $ d
-  where
-    gToO = avgScale globalToOutput
 
-    -- Scaling factor from normalized units to output units: nth root
-    -- 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))
-
--- | 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
+-- XXX Of course we need a real 'Context' and to iterate the diagram.
+toRTree globalToOutput (QD d) = fst $ runContextual d initialContext
+  where
+    initialContext = (Option Nothing, (Option Nothing, ()))
 
 --------------------------------------------------
 

src/Diagrams/Core/Context.hs

@@ -0,0 +1,79 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeOperators              #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Diagrams.Core.Context
+-- Copyright   :  (c) 2014 diagrams-core team (see LICENSE)
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  [email protected]
+--
+-- XXX comment me
+--
+-----------------------------------------------------------------------------
+
+module Diagrams.Core.Context
+  ( Context
+  , Contextual (..)
+  , contextual
+  , runContextual
+  )
+  where
+
+import           Diagrams.Core.Names
+import           Diagrams.Core.Style
+import           Diagrams.Core.Transform
+import           Diagrams.Core.V
+
+import           Control.Applicative
+import           Control.Lens            (Rewrapped, Wrapped (..), iso, over,
+                                          view)
+import           Control.Monad.Reader
+import           Data.Monoid.MList
+import           Data.Semigroup
+
+-- | The (monoidal) context in which a diagram is interpreted.
+--   Contexts can be thought of as accumulating along each path to a
+--   leaf:
+--
+--   * styles (see "Diagrams.Core.Style")
+--
+--   * names (see "Diagrams.Core.Names")
+type Context v n = Style v n
+               ::: Name
+               ::: ()
+
+--------------------------------------------------
+-- Context monad
+
+newtype Contextual v n a = Contextual (Reader (Context v n) a)
+  deriving (Functor, Applicative, Monad, MonadReader (Context v n))
+
+instance Wrapped (Contextual v n a) where
+  type Unwrapped (Contextual v n a) = Context v n -> a
+  _Wrapped' = iso (\(Contextual r) -> runReader r) (Contextual . reader)
+
+-- | Smart constructor for 'Contextual' values.
+--
+--   Note @contextual = review _Wrapped'@.
+contextual :: (Context v n -> a) -> Contextual v n a
+contextual = Contextual . reader
+
+runContextual :: Contextual v n a -> (Context v n -> a)
+runContextual = view _Wrapped'
+
+instance Rewrapped (Contextual v n a) (Contextual v' n' a')
+
+type instance V (Contextual v n a) = V a
+type instance N (Contextual v n a) = N a
+
+instance Semigroup a => Semigroup (Contextual v n a) where
+  Contextual r1 <> Contextual r2 = Contextual . reader $ \ctx -> runReader r1 ctx <> runReader r2 ctx
+
+instance (Semigroup a, Monoid a) => Monoid (Contextual v n a) where
+  mappend = (<>)
+  mempty  = Contextual . reader $ const mempty
+
+instance Transformable a => Transformable (Contextual v n a) where
+  transform = over _Wrapped' . fmap . transform

src/Diagrams/Core/Envelope.hs

@@ -53,6 +53,7 @@ import           Data.Semigroup
 import qualified Data.Set                as S
 import           Data.Functor.Rep
 
+import           Diagrams.Core.Context
 import           Diagrams.Core.HasOrigin
 import           Diagrams.Core.Points
 import           Diagrams.Core.Transform
@@ -179,13 +180,13 @@ class (Metric (V a), OrderedField (N a)) => Enveloped a where
   --   Other types (e.g. 'Trail') may have some other default
   --   reference point at which the envelope will be based; their
   --   instances should document what it is.
-  getEnvelope :: a -> Envelope (V a) (N a)
+  getEnvelope :: a -> Contextual (V a) (N a) (Envelope (V a) (N a))
 
 instance (Metric v, OrderedField n) => Enveloped (Envelope v n) where
-  getEnvelope = id
+  getEnvelope = return
 
 instance (OrderedField n, Metric v) => Enveloped (Point v n) where
-  getEnvelope p = moveTo p . mkEnvelope $ const 0
+  getEnvelope p = return . moveTo p . mkEnvelope $ const 0
 
 instance Enveloped t => Enveloped (TransInv t) where
   getEnvelope = getEnvelope . op TransInv
@@ -209,24 +210,24 @@ instance Enveloped b => Enveloped (S.Set b) where
 -- | Compute the vector from the local origin to a separating
 --   hyperplane in the given direction, or @Nothing@ for the empty
 --   envelope.
-envelopeVMay :: Enveloped a => Vn a -> a -> Maybe (Vn a)
-envelopeVMay v = fmap ((*^ v) . ($ v)) . appEnvelope . getEnvelope
+envelopeVMay :: Enveloped a => Vn a -> a -> Contextual (V a) (N a) (Maybe (Vn a))
+envelopeVMay v = fmap (fmap ((*^ v) . ($ v)) . appEnvelope) . getEnvelope
 
 -- | Compute the vector from the local origin to a separating
 --   hyperplane in the given direction.  Returns the zero vector for
 --   the empty envelope.
-envelopeV :: Enveloped a => Vn a -> a -> Vn a
-envelopeV v = fromMaybe zero . envelopeVMay v
+envelopeV :: Enveloped a => Vn a -> a -> Contextual (V a) (N a) (Vn a)
+envelopeV v = fmap (fromMaybe zero) . envelopeVMay v
 
 -- | Compute the point on a separating hyperplane in the given
 --   direction, or @Nothing@ for the empty envelope.
-envelopePMay :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Maybe (Point v n)
-envelopePMay v = fmap P . envelopeVMay v
+envelopePMay :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Contextual v n (Maybe (Point v n))
+envelopePMay v = fmap (fmap P) . envelopeVMay v
 
 -- | Compute the point on a separating hyperplane in the given
 --   direction.  Returns the origin for the empty envelope.
-envelopeP :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Point v n
-envelopeP v = P . envelopeV v
+envelopeP :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Contextual v n (Point v n)
+envelopeP v = fmap P . envelopeV v
 
 -- | Equivalent to the norm of 'envelopeVMay':
 --
@@ -237,8 +238,8 @@ envelopeP v = P . envelopeV v
 --   Note that the 'envelopeVMay' / 'envelopePMay' functions above should be
 --   preferred, as this requires a call to norm.  However, it is more
 --   efficient than calling norm on the results of those functions.
-envelopeSMay :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Maybe n
-envelopeSMay v = fmap ((* norm v) . ($ v)) . appEnvelope . getEnvelope
+envelopeSMay :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Contextual v n (Maybe n)
+envelopeSMay v = fmap (fmap ((* norm v) . ($ v)) . appEnvelope) . getEnvelope
 
 -- | Equivalent to the norm of 'envelopeV':
 --
@@ -249,27 +250,27 @@ envelopeSMay v = fmap ((* norm v) . ($ v)) . appEnvelope . getEnvelope
 --   Note that the 'envelopeV' / 'envelopeP' functions above should be
 --   preferred, as this requires a call to norm. However, it is more
 --   efficient than calling norm on the results of those functions.
-envelopeS :: (V a ~ v, N a ~ n, Enveloped a, Num n) => v n -> a -> n
-envelopeS v = fromMaybe 0 . envelopeSMay v
+envelopeS :: (V a ~ v, N a ~ n, Enveloped a, Num n) => v n -> a -> Contextual v n n
+envelopeS v = fmap (fromMaybe 0) . envelopeSMay v
 
 -- | Compute the diameter of a enveloped object along a particular
 --   vector.  Returns zero for the empty envelope.
-diameter :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> n
-diameter v a = maybe 0 (\(lo,hi) -> (hi - lo) * norm v) (extent v a)
+diameter :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Contextual v n n
+diameter v = fmap (maybe 0 (\(lo,hi) -> (hi - lo) * norm v)) . extent v
 
 -- | Compute the \"radius\" (1\/2 the diameter) of an enveloped object
 --   along a particular vector.
-radius :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> n
-radius v = (0.5*) . diameter v
+radius :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Contextual v n n
+radius v = fmap (0.5*) . diameter v
 
 -- | Compute the range of an enveloped object along a certain
 --   direction.  Returns a pair of scalars @(lo,hi)@ such that the
 --   object extends from @(lo *^ v)@ to @(hi *^ v)@. Returns @Nothing@
 --   for objects with an empty envelope.
-extent :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Maybe (n, n)
-extent v a = (\f -> (-f (negated v), f v)) <$> (appEnvelope . getEnvelope $ a)
+extent :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Contextual v n (Maybe (n, n))
+extent v a = (fmap (( fmap (\f -> (-f (negated v), f v))) . appEnvelope)) (getEnvelope a)
 
 -- | The smallest positive vector that bounds the envelope of an object.
-size :: (V a ~ v, N a ~ n, Enveloped a, HasBasis v) => a -> v n
-size d = tabulate $ \(E l) -> diameter (zero & l .~ 1) d
+size :: (V a ~ v, N a ~ n, Enveloped a, HasBasis v) => a -> Contextual v n (v n)
+size d = undefined --fmap (tabulate $ \(E l) -> diameter (zero & l .~ 1)) d