diagrams-core 0.7.0.1 → 1.0
raw patch · 14 files changed
+507/−126 lines, 14 filesdep +lensdep ~dual-tree
Dependencies added: lens
Dependency ranges changed: dual-tree
Files
- CHANGES.markdown +48/−0
- LICENSE +3/−0
- diagrams-core.cabal +4/−2
- src/Diagrams/Core.hs +6/−6
- src/Diagrams/Core/Compile.hs +130/−0
- src/Diagrams/Core/Envelope.hs +11/−8
- src/Diagrams/Core/Juxtapose.hs +3/−0
- src/Diagrams/Core/Names.hs +27/−1
- src/Diagrams/Core/Query.hs +9/−2
- src/Diagrams/Core/Style.hs +9/−0
- src/Diagrams/Core/Trace.hs +17/−10
- src/Diagrams/Core/Transform.hs +7/−2
- src/Diagrams/Core/Types.hs +232/−94
- src/Diagrams/Core/V.hs +1/−1
CHANGES.markdown view
@@ -1,3 +1,51 @@+1.0 (25 November 2013)+----------------------++* **New features**++ * Delayed subtrees: instead of a primitive, one can now also have+ a delayed subtree at a leaf, containing a continuation which+ generates a `QDiagram` when given the accumulated d-annotation+ at that point in the tree. Useful for things which need to know+ the final transformation applied to them before deciding what+ diagram to generate. The prototypical use case is arrows: see+ https://github.com/diagrams/diagrams-lib/issues/112 . However,+ this may be useful for other things as well: for example,+ diagrams which scale normally until hitting some maximum or+ minimum size, at which point they refuse to scale any further+ (or more generally diagrams which scale as some non-linear+ function of the transformation applied to them).++ The only downside is that the u-annotation must be fixed ahead+ of time---doing otherwise requires a more general solution for+ constraint solving.++ * New function `lookupName` for doing a simple lookup of a named+ subdiagram++ * New module `Diagrams.Core.Compile`, containing a framework for+ compiling `QDiagrams` into a simpler tree type `RTree`, which+ may be used by backends for rendering.++* **New instances**++ * `Qualifiable` instances for `(,)`, `(,,)`, `[]`, `Set`, `Map k`,+ and `(->) e`.++ * `(->) e` instance for `Juxtaposable` (thanks to Carlos Scheidegger)++* **API changes**++ * Export `pointDiagram` function, which creates an otherwise empty+ diagram with a point (not empty) envelope++ * A bunch of stuff now uses machinery from the `lens` library.+ * `envelope`, `trace`, and `subMap` are now `Lens'`es+ * `Wrapped` instances for `Trace`, `TransInv`, `QDiagram`,+ `SubMap`, `Envelope`, `Style`, `Query`, and `Name` (replaces+ `Newtype` instances)+ * `Iso`s for `Query`, `Envelope`, `QDiagram`, `SubMap`, `TransInv`+ 0.7.0.1 (26 September 2013) ---------------------------
LICENSE view
@@ -3,6 +3,9 @@ Daniel Bergey <bergey@alum.mit.edu> Conal Elliott <conal@conal.net> Sam Griffin <sam.griffin@gmail.com>+ Chris Mears <chris@cmears.id.au>+ Jeffrey Rosenbluth <Jeffrey.Rosenbluth@gmail.com>+ Carlos Scheidegger <cscheid@research.att.com> Vilhelm Sjöberg <vilhelm.sjoberg@gmail.com> Michael Sloan <mgsloan@gmail.com> Scott Walck <walck@lvc.edu>
diagrams-core.cabal view
@@ -1,5 +1,5 @@ Name: diagrams-core-Version: 0.7.0.1+Version: 1.0 Synopsis: Core libraries for diagrams EDSL Description: The core modules underlying diagrams, an embedded domain-specific language@@ -21,6 +21,7 @@ Library Exposed-modules: Diagrams.Core,+ Diagrams.Core.Compile, Diagrams.Core.Envelope, Diagrams.Core.HasOrigin, Diagrams.Core.Juxtapose,@@ -41,7 +42,8 @@ MemoTrie >= 0.4.7 && < 0.7, newtype >= 0.2 && < 0.3, monoid-extras >= 0.3 && < 0.4,- dual-tree >= 0.1 && < 0.2+ dual-tree >= 0.2 && < 0.3,+ lens >= 3.8 && < 4 hs-source-dirs: src
src/Diagrams/Core.hs view
@@ -52,7 +52,7 @@ -- ** Translational invariance - , TransInv(..)+ , TransInv(TransInv) -- * Names @@ -79,16 +79,16 @@ -- * Envelopes - , Envelope- , inEnvelope, appEnvelope, onEnvelope, mkEnvelope+ , Envelope(..)+ , appEnvelope, onEnvelope, mkEnvelope , Enveloped(..) , envelopeVMay, envelopeV, envelopePMay, envelopeP , diameter, radius -- * Traces - , Trace(..)- , inTrace, mkTrace+ , Trace(Trace)+ , appTrace, mkTrace , Traced(..) , traceV, traceP , maxTraceV, maxTraceP@@ -111,7 +111,7 @@ -- * Diagrams - , QDiagram, mkQD, Diagram+ , QDiagram, Diagram, mkQD, pointDiagram , prims , envelope, trace, subMap, names, query, sample , value, resetValue, clearValue
+ src/Diagrams/Core/Compile.hs view
@@ -0,0 +1,130 @@++-----------------------------------------------------------------------------+-- |+-- Module : Diagrams.Core.Compile+-- Copyright : (c) 2013 diagrams-core team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- This module provides tools for compiling @QDiagrams@ into a more+-- convenient and optimized tree form, suitable for use by backends.+--+-----------------------------------------------------------------------------++module Diagrams.Core.Compile+ ( -- * Tools for backends+ RNode(..)+ , RTree+ , toRTree++ -- * Internals++ , toDTree+ , fromDTree+ )+ where++import qualified Data.List.NonEmpty as NEL+import Data.Maybe (fromMaybe)+import Data.Monoid.Coproduct+import Data.Monoid.MList+import Data.Monoid.Split+import Data.Semigroup+import Data.Tree+import Data.Tree.DUAL+import Diagrams.Core.Transform+import Diagrams.Core.Types++emptyDTree :: Tree (DNode b v a)+emptyDTree = Node DEmpty []++-- | Convert a @QDiagram@ into a raw tree.+toDTree :: HasLinearMap v => QDiagram b v m -> Maybe (DTree b v ())+toDTree (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 . ($d))+ )++ -- 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 (Split (Transformation v))@;+-- in the @RTree@ the frozen part of the transform is put in a node of type+-- @RFrozenTr (Transformation v)@ and the unfrozen part is pushed down until+-- it is either frozen or reaches a primitive node.+fromDTree :: HasLinearMap v => DTree b v () -> RTree b v ()+fromDTree = fromDTree' mempty+ where+ fromDTree' :: HasLinearMap v => Transformation v -> DTree b v () -> RTree b v ()+ -- We put the accumulated unfrozen transformation (accTr) and the prim+ -- into an RPrim node.+ fromDTree' accTr (Node (DPrim p) _)+ = Node (RPrim 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)++ -- Unfrozen transformations are accumulated and pushed down as well.+ fromDTree' accTr (Node (DTransform (M tr)) ts)+ = Node REmpty (fmap (fromDTree' (accTr <> tr)) ts)++ -- Frozen transformations are stored in the RFrozenTr node+ -- and accTr is reset to the unfrozen part of the transform.+ fromDTree' accTr (Node (DTransform (tr1 :| tr2)) ts)+ = Node (RFrozenTr (accTr <> tr1)) (fmap (fromDTree' tr2) ts)++ -- Drop accumulated transformations upon encountering a DDelay+ -- node --- the tree unfolded beneath it already took into account+ -- any non-frozen transformation at this point.+ fromDTree' _ (Node DDelay ts)+ = Node REmpty (fmap (fromDTree' mempty) ts)++ -- DAnnot and DEmpty nodes become REmpties, in the future my want to+ -- handle DAnnots separately if they are used, again accTr flows through.+ fromDTree' accTr (Node _ ts)+ = Node REmpty (fmap (fromDTree' accTr) ts)++-- | Compile a @QDiagram@ into an 'RTree'. Suitable for use by+-- backends when implementing 'renderData'.+toRTree :: HasLinearMap v => QDiagram b v m -> RTree b v ()+toRTree = fromDTree . fromMaybe (Node DEmpty []) . toDTree
src/Diagrams/Core/Envelope.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Diagrams.Envelope@@ -25,7 +26,6 @@ ( -- * Envelopes Envelope(..) - , inEnvelope , appEnvelope , onEnvelope , mkEnvelope@@ -43,12 +43,12 @@ ) where import Control.Applicative ((<$>))+import Control.Lens (Wrapped(..), iso, view, over, mapped, unwrapped) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Semigroup import qualified Data.Set as S -import Data.AffineSpace ((.+^), (.-^)) import Data.VectorSpace import Diagrams.Core.HasOrigin@@ -94,17 +94,20 @@ -- The idea for envelopes came from -- Sebastian Setzer; see -- <http://byorgey.wordpress.com/2009/10/28/collecting-attributes/#comment-2030>. See also Brent Yorgey, /Monoids: Theme and Variations/, published in the 2012 Haskell Symposium: <http://www.cis.upenn.edu/~byorgey/pub/monoid-pearl.pdf>; video: <http://www.youtube.com/watch?v=X-8NCkD2vOw>.-newtype Envelope v = Envelope { unEnvelope :: Option (v -> Max (Scalar v)) }+newtype Envelope v = Envelope (Option (v -> Max (Scalar v))) -inEnvelope :: (Option (v -> Max (Scalar v)) -> Option (v -> Max (Scalar v)))- -> Envelope v -> Envelope v-inEnvelope f = Envelope . f . unEnvelope+instance (Scalar v ~ s, Scalar v' ~ s', s ~ s')+ => Wrapped+ (Option (v -> Max s))+ (Option (v' -> Max s'))+ (Envelope v) (Envelope v')+ where wrapped = iso Envelope (\(Envelope e) -> e) appEnvelope :: Envelope v -> Maybe (v -> Scalar v) appEnvelope (Envelope (Option e)) = (getMax .) <$> e onEnvelope :: ((v -> Scalar v) -> (v -> Scalar v)) -> Envelope v -> Envelope v-onEnvelope t = (inEnvelope . fmap) ((Max .) . t . (getMax .))+onEnvelope t = over (unwrapped . mapped) ((Max .) . t . (getMax .)) mkEnvelope :: (v -> Scalar v) -> Envelope v mkEnvelope = Envelope . Option . Just . (Max .)@@ -185,7 +188,7 @@ getEnvelope p = moveTo p . mkEnvelope $ const zeroV instance Enveloped t => Enveloped (TransInv t) where- getEnvelope = getEnvelope . unTransInv+ getEnvelope = getEnvelope . view unwrapped instance (Enveloped a, Enveloped b, V a ~ V b) => Enveloped (a,b) where getEnvelope (x,y) = getEnvelope x <> getEnvelope y
src/Diagrams/Core/Juxtapose.hs view
@@ -66,3 +66,6 @@ instance (Enveloped b, HasOrigin b, Ord b) => Juxtaposable (S.Set b) where juxtapose = juxtaposeDefault++instance Juxtaposable a => Juxtaposable (b -> a) where+ juxtapose v f1 f2 b = juxtapose v (f1 b) (f2 b)
src/Diagrams/Core/Names.hs view
@@ -2,7 +2,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- |@@ -29,8 +31,11 @@ ) where +import Control.Lens (over, unwrapped, Wrapped(..), iso) import Data.List (intercalate)+import qualified Data.Map as M import Data.Semigroup+import qualified Data.Set as S import Data.Typeable import Diagrams.Core.Transform@@ -87,6 +92,9 @@ newtype Name = Name [AName] deriving (Eq, Ord, Semigroup, Monoid, Typeable) +instance Wrapped [AName] [AName] Name Name+ where wrapped = iso Name (\(Name ans) -> ans)+ instance Show Name where show (Name ns) = intercalate " .> " $ map show ns @@ -110,7 +118,25 @@ (|>) = (.>) instance Qualifiable a => Qualifiable (TransInv a) where- (|>) n = TransInv . (|>) n . unTransInv+ (|>) n = over unwrapped (n |>)++instance (Qualifiable a, Qualifiable b) => Qualifiable (a,b) where+ n |> (a,b) = (n |> a, n |> b)++instance (Qualifiable a, Qualifiable b, Qualifiable c) => Qualifiable (a,b,c) where+ n |> (a,b,c) = (n |> a, n |> b, n |> c)++instance Qualifiable a => Qualifiable [a] where+ n |> as = map (n |>) as++instance (Ord a, Qualifiable a) => Qualifiable (S.Set a) where+ n |> s = S.map (n |>) s++instance Qualifiable a => Qualifiable (M.Map k a) where+ n |> m = fmap (n |>) m++instance Qualifiable a => Qualifiable (b -> a) where+ n |> f = (n |>) . f infixr 5 |> infixr 5 .>
src/Diagrams/Core/Query.hs view
@@ -1,5 +1,8 @@-{-# LANGUAGE TypeFamilies+{-# LANGUAGE FlexibleInstances , GeneralizedNewtypeDeriving+ , MultiParamTypeClasses+ , TemplateHaskell+ , TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -14,10 +17,11 @@ ----------------------------------------------------------------------------- module Diagrams.Core.Query- ( Query(..)+ ( Query(Query), runQuery ) where import Control.Applicative+import Control.Lens (Wrapped(..), iso) import Data.Semigroup import Data.AffineSpace@@ -40,6 +44,9 @@ -- the graphics-drawingcombinators package, <http://hackage.haskell.org/package/graphics-drawingcombinators>. newtype Query v m = Query { runQuery :: Point v -> m } deriving (Functor, Applicative, Semigroup, Monoid)++instance Wrapped (Point v -> m) (Point v' -> m') (Query v m) (Query v' m')+ where wrapped = iso Query runQuery type instance V (Query v m) = v
src/Diagrams/Core/Style.hs view
@@ -3,6 +3,7 @@ , KindSignatures , FlexibleInstances , MultiParamTypeClasses+ , TemplateHaskell , TypeFamilies , UndecidableInstances #-}@@ -43,6 +44,7 @@ ) where import Control.Arrow ((***))+import Control.Lens (Wrapped(..), iso) import qualified Data.Map as M import Data.Semigroup import qualified Data.Set as S@@ -137,6 +139,13 @@ newtype Style v = Style (M.Map String (Attribute v)) -- The String keys are serialized TypeRep values, corresponding to -- the type of the stored attribute.++instance Wrapped+ (M.Map String (Attribute v))+ (M.Map String (Attribute v'))+ (Style v)+ (Style v')+ where wrapped = iso Style (\(Style m) -> m) type instance V (Style v) = v
src/Diagrams/Core/Trace.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -23,9 +26,9 @@ module Diagrams.Core.Trace ( -- * Traces- Trace(..)+ Trace(Trace) - , inTrace+ , appTrace , mkTrace -- * Traced class@@ -40,6 +43,7 @@ ) where import Control.Applicative+import Control.Lens import qualified Data.Map as M import Data.Semigroup import qualified Data.Set as S@@ -76,9 +80,12 @@ newtype Trace v = Trace { appTrace :: Point v -> v -> PosInf (Scalar v) } -inTrace :: ((Point v -> v -> PosInf (Scalar v)) -> (Point v -> v -> PosInf (Scalar v)))- -> Trace v -> Trace v-inTrace f = Trace . f . appTrace+instance (Scalar v ~ s, Scalar v' ~ s', s ~ s') =>+ Wrapped+ (Point v -> v -> PosInf s)+ (Point v' -> v' -> PosInf s')+ (Trace v) (Trace v')+ where wrapped = iso Trace appTrace mkTrace :: (Point v -> v -> PosInf (Scalar v)) -> Trace v mkTrace = Trace@@ -96,7 +103,7 @@ type instance V (Trace v) = v instance (VectorSpace v) => HasOrigin (Trace v) where- moveOriginTo (P u) = inTrace $ \f p -> f (p .+^ u)+ moveOriginTo (P u) = unwrapping Trace %~ \f p -> f (p .+^ u) instance Show (Trace v) where show _ = "<trace>"@@ -106,7 +113,7 @@ ------------------------------------------------------------ instance HasLinearMap v => Transformable (Trace v) where- transform t = inTrace $ \f p v -> f (papply (inv t) p) (apply (inv t) v)+ transform t = unwrapped %~ \f p v -> f (papply (inv t) p) (apply (inv t) v) ------------------------------------------------------------ -- Traced class ------------------------------------------@@ -129,10 +136,10 @@ -- envelope for a single point is /not/ the empty envelope (see -- "Diagrams.Core.Envelope"). instance (Ord (Scalar v), VectorSpace v) => Traced (Point v) where- getTrace p = mempty+ getTrace = const mempty instance Traced t => Traced (TransInv t) where- getTrace = getTrace . unTransInv+ getTrace = getTrace . view unwrapped instance (Traced a, Traced b, V a ~ V b) => Traced (a,b) where getTrace (x,y) = getTrace x <> getTrace y@@ -154,7 +161,7 @@ -- given object in the given direction, or @Nothing@ if there is no -- intersection. traceV :: Traced a => Point (V a) -> V a -> a -> Maybe (V a)-traceV p v a = case appTrace (getTrace a) p v of+traceV p v a = case ((getTrace a)^.unwrapping Trace) p v of Finite s -> Just (s *^ v) Infinity -> Nothing
src/Diagrams/Core/Transform.hs view
@@ -5,6 +5,7 @@ , TypeFamilies , MultiParamTypeClasses , GeneralizedNewtypeDeriving+ , TemplateHaskell , TypeSynonymInstances , ScopedTypeVariables #-}@@ -47,7 +48,7 @@ -- * Translational invariance - , TransInv(..)+ , TransInv(TransInv) -- * Vector space independent transformations -- | Most transformations are specific to a particular vector@@ -59,6 +60,7 @@ ) where +import Control.Lens (Wrapped(..), iso) import qualified Data.Map as M import Data.Semigroup import qualified Data.Set as S@@ -270,8 +272,11 @@ -- translationally invariant; the translational component of -- transformations will no longer affect things wrapped in -- @TransInv@.-newtype TransInv t = TransInv { unTransInv :: t }+newtype TransInv t = TransInv t deriving (Eq, Ord, Show, Semigroup, Monoid)++instance Wrapped t t' (TransInv t) (TransInv t')+ where wrapped = iso TransInv (\(TransInv t) -> t) type instance V (TransInv t) = V t
src/Diagrams/Core/Types.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-}@@ -12,10 +13,14 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-}+-- We have some orphan Action instances here, but since Action is a multi-param+-- class there is really no better place to put them.+ ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Types--- Copyright : (c) 2011-2012 diagrams-core team (see LICENSE)+-- Copyright : (c) 2011-2013 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com --@@ -40,10 +45,15 @@ -- * Diagrams -- ** Annotations- UpAnnots, DownAnnots- , QDiagram(..), mkQD, Diagram+ UpAnnots, DownAnnots, transfToAnnot, transfFromAnnot+ -- ** Basic type definitions+ , QDiaLeaf(..), withQDiaLeaf+ , QDiagram(..), Diagram -- * Operations on diagrams+ -- ** Creating diagrams+ , mkQD, mkQD', pointDiagram+ -- ** Extracting information , prims , envelope, trace, subMap, names, query, sample@@ -59,6 +69,7 @@ -- ** Modifying diagrams -- *** Names , nameSub+ , lookupName , withName , withNameAll , withNames@@ -91,6 +102,10 @@ , Backend(..) , MultiBackend(..)+ , DNode(..)+ , DTree+ , RNode(..)+ , RTree -- ** Null backend @@ -102,16 +117,17 @@ ) where -import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first, second, (***))+import Control.Lens (Lens', Wrapped (..), iso, lens,+ over, unwrapped, view, (^.)) import Control.Monad (mplus)-import Control.Newtype import Data.AffineSpace ((.-.)) import Data.List (isSuffixOf) import qualified Data.Map as M import Data.Maybe (fromMaybe, listToMaybe) import Data.Semigroup import qualified Data.Traversable as T+import Data.Tree import Data.Typeable import Data.VectorSpace @@ -193,19 +209,41 @@ transfFromAnnot :: HasLinearMap v => DownAnnots v -> Transformation v transfFromAnnot = option mempty (unsplit . killR) . fst +-- | A leaf in a 'QDiagram' tree is either a 'Prim', or a \"delayed\"+-- @QDiagram@ which expands to a real @QDiagram@ once it learns the+-- \"final context\" in which it will be rendered. For example, in+-- order to decide how to draw an arrow, we must know the precise+-- transformation applied to it (since the arrow head and tail are+-- scale-invariant).+data QDiaLeaf b v m+ = PrimLeaf (Prim b v)+ | DelayedLeaf (DownAnnots v -> QDiagram b v m)+ -- ^ The @QDiagram@ produced by a @DelayedLeaf@ function /must/+ -- already apply any non-frozen transformation in the given+ -- @DownAnnots@ (that is, the non-frozen transformation will not+ -- be applied by the context). On the other hand, it must assume+ -- that any frozen transformation or attributes will be applied+ -- by the context.+ deriving (Functor)++withQDiaLeaf :: (Prim b v -> r) -> ((DownAnnots v -> QDiagram b v m) -> r) -> (QDiaLeaf b v m -> r)+withQDiaLeaf f _ (PrimLeaf p) = f p+withQDiaLeaf _ g (DelayedLeaf d) = g d+ -- | The fundamental diagram type is represented by trees of -- primitives with various monoidal annotations. The @Q@ in -- @QDiagram@ stands for \"Queriable\", as distinguished from -- 'Diagram', a synonym for @QDiagram@ with the query type -- specialized to 'Any'. newtype QDiagram b v m- = QD { unQD :: D.DUALTree (DownAnnots v) (UpAnnots b v m) () (Prim b v) }+ = QD (D.DUALTree (DownAnnots v) (UpAnnots b v m) () (QDiaLeaf b v m)) deriving (Typeable) -instance Newtype (QDiagram b v m)- (D.DUALTree (DownAnnots v) (UpAnnots b v m) () (Prim b v)) where- pack = QD- unpack = unQD+instance Wrapped+ (D.DUALTree (DownAnnots v) (UpAnnots b v m) () (QDiaLeaf b v m))+ (D.DUALTree (DownAnnots v') (UpAnnots b' v' m') () (QDiaLeaf b' v' m'))+ (QDiagram b v m) (QDiagram b' v' m')+ where wrapped = iso QD (\(QD d) -> d) type instance V (QDiagram b v m) = v @@ -226,9 +264,12 @@ -- associated transformations and styles. prims :: HasLinearMap v => QDiagram b v m -> [(Prim b v, (Split (Transformation v), Style v))]-prims = (map . second) (untangle . option mempty id . fst)+prims = concatMap processLeaf . D.flatten- . unQD+ . view unwrapped+ where+ processLeaf (PrimLeaf p, (trSty,_)) = [(p, untangle . option mempty id $ trSty)]+ processLeaf (DelayedLeaf k, d) = prims (k d) -- | A useful variant of 'getU' which projects out a certain -- component.@@ -236,89 +277,111 @@ getU' = maybe mempty (option mempty id . get) . D.getU -- | Get the envelope of a diagram.-envelope :: (Ord (Scalar v))- => QDiagram b v m -> Envelope v-envelope = unDelete . getU' . unQD+envelope :: forall b v m. (OrderedField (Scalar v), InnerSpace v+ , HasLinearMap v, Monoid' m)+ => Lens' (QDiagram b v m) (Envelope v)+envelope = lens (unDelete . getU' . view unwrapped) (flip setEnvelope) -- | Replace the envelope of a diagram.-setEnvelope :: forall b v m. (OrderedField (Scalar v), InnerSpace v, HasLinearMap v, Monoid' m)+setEnvelope :: forall b v m. (OrderedField (Scalar v), InnerSpace v+ , HasLinearMap v, Monoid' m) => Envelope v -> QDiagram b v m -> QDiagram b v m-setEnvelope e = over QD ( D.applyUpre (inj . toDeletable $ e)- . D.applyUpre (inj (deleteL :: Deletable (Envelope v)))- . D.applyUpost (inj (deleteR :: Deletable (Envelope v)))- )+setEnvelope e =+ over unwrapped ( D.applyUpre (inj . toDeletable $ e)+ . D.applyUpre (inj (deleteL :: Deletable (Envelope v)))+ . D.applyUpost (inj (deleteR :: Deletable (Envelope v)))+ ) -- | Get the trace of a diagram.-trace :: (Ord (Scalar v), VectorSpace v, HasLinearMap v) => QDiagram b v m -> Trace v-trace = unDelete . getU' . unQD+trace :: (InnerSpace v, HasLinearMap v, OrderedField (Scalar v), Semigroup m) =>+ Lens' (QDiagram b v m) (Trace v)+trace = lens (unDelete . getU' . view unwrapped) (flip setTrace) -- | Replace the trace of a diagram.-setTrace :: forall b v m. (OrderedField (Scalar v), InnerSpace v, HasLinearMap v, Semigroup m)+setTrace :: forall b v m. (OrderedField (Scalar v), InnerSpace v+ , HasLinearMap v, Semigroup m) => Trace v -> QDiagram b v m -> QDiagram b v m-setTrace t = over QD ( D.applyUpre (inj . toDeletable $ t)- . D.applyUpre (inj (deleteL :: Deletable (Trace v)))- . D.applyUpost (inj (deleteR :: Deletable (Trace v)))- )+setTrace t = over unwrapped ( D.applyUpre (inj . toDeletable $ t)+ . D.applyUpre (inj (deleteL :: Deletable (Trace v)))+ . D.applyUpost (inj (deleteR :: Deletable (Trace v)))+ ) -- | Get the subdiagram map (/i.e./ an association from names to -- subdiagrams) of a diagram.-subMap :: QDiagram b v m -> SubMap b v m-subMap = unDelete . getU' . unQD+subMap :: (HasLinearMap v, InnerSpace v, Semigroup m, OrderedField (Scalar v)) =>+ Lens' (QDiagram b v m) (SubMap b v m)+subMap = lens (unDelete . getU' . view unwrapped) (flip setMap) where+ setMap :: (HasLinearMap v, InnerSpace v, Semigroup m, OrderedField (Scalar v)) =>+ SubMap b v m -> QDiagram b v m -> QDiagram b v m+ setMap m = over unwrapped ( D.applyUpre . inj . toDeletable $ m) -- | Get a list of names of subdiagrams and their locations.-names :: HasLinearMap v => QDiagram b v m -> [(Name, [Point v])]-names = (map . second . map) location . M.assocs . unpack . subMap+names :: (HasLinearMap v, InnerSpace v, Semigroup m, OrderedField (Scalar v))+ => QDiagram b v m -> [(Name, [Point v])]+names = (map . second . map) location . M.assocs . view (subMap . unwrapped) -- | Attach an atomic name to a certain subdiagram, computed from the -- given diagram. nameSub :: ( IsName n , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => (QDiagram b v m -> Subdiagram b v m) -> n -> QDiagram b v m -> QDiagram b v m-nameSub s n d = over QD (D.applyUpre . inj . toDeletable $ fromNames [(n,s d)]) d+nameSub s n d = over unwrapped (D.applyUpre . inj . toDeletable $ fromNames [(n,s d)]) d +-- | Lookup the most recent diagram associated with (some+-- qualification of) the given name.+lookupName :: (IsName n, HasLinearMap v, InnerSpace v+ , Semigroup m, OrderedField (Scalar v))+ => n -> QDiagram b v m -> Maybe (Subdiagram b v m)+lookupName n d = lookupSub (toName n) (d^.subMap) >>= listToMaybe+ -- | Given a name and a diagram transformation indexed by a -- subdiagram, perform the transformation using the most recent -- subdiagram associated with (some qualification of) the name, -- or perform the identity transformation if the name does not exist.-withName :: IsName n+withName :: (IsName n, HasLinearMap v, InnerSpace v+ , Semigroup m, OrderedField (Scalar v)) => n -> (Subdiagram b v m -> QDiagram b v m -> QDiagram b v m) -> QDiagram b v m -> QDiagram b v m-withName n f d = maybe id f (lookupSub (toName n) (subMap d) >>= listToMaybe) d+withName n f d = maybe id f (lookupName n d) d -- | Given a name and a diagram transformation indexed by a list of -- subdiagrams, perform the transformation using the -- collection of all such subdiagrams associated with (some -- qualification of) the given name.-withNameAll :: IsName n+withNameAll :: (IsName n, HasLinearMap v, InnerSpace v+ , Semigroup m, OrderedField (Scalar v)) => n -> ([Subdiagram b v m] -> QDiagram b v m -> QDiagram b v m) -> QDiagram b v m -> QDiagram b v m-withNameAll n f d = f (fromMaybe [] (lookupSub (toName n) (subMap d))) d+withNameAll n f d = f (fromMaybe [] (lookupSub (toName n) (d^.subMap))) d -- | Given a list of names and a diagram transformation indexed by a -- list of subdiagrams, perform the transformation using the -- list of most recent subdiagrams associated with (some qualification -- of) each name. Do nothing (the identity transformation) if any -- of the names do not exist.-withNames :: IsName n+withNames :: (IsName n, HasLinearMap v, InnerSpace v+ , Semigroup m, OrderedField (Scalar v)) => [n] -> ([Subdiagram b v m] -> QDiagram b v m -> QDiagram b v m) -> QDiagram b v m -> QDiagram b v m-withNames ns f d = maybe id f (T.sequence (map ((listToMaybe=<<) . ($nd) . lookupSub . toName) ns)) d- where nd = subMap d+withNames ns f d = maybe id f ns' d+ where+ nd = d^.subMap+ ns' = T.sequence (map ((listToMaybe=<<) . ($nd) . lookupSub . toName) ns) -- | \"Localize\" a diagram by hiding all the names, so they are no -- longer visible to the outside.-localize :: forall b v m. ( HasLinearMap v, InnerSpace v, OrderedField (Scalar v)- , Semigroup m+localize :: forall b v m. ( HasLinearMap v, InnerSpace v+ , OrderedField (Scalar v), Semigroup m ) => QDiagram b v m -> QDiagram b v m-localize = over QD ( D.applyUpre (inj (deleteL :: Deletable (SubMap b v m)))+localize = over unwrapped ( D.applyUpre (inj (deleteL :: Deletable (SubMap b v m))) . D.applyUpost (inj (deleteR :: Deletable (SubMap b v m))) ) -- | Get the query function associated with a diagram. query :: Monoid m => QDiagram b v m -> Query v m-query = getU' . unQD+query = getU' . view unwrapped -- | Sample a diagram's query function at a given point. sample :: Monoid m => QDiagram b v m -> Point v -> m@@ -345,10 +408,17 @@ -- | Create a diagram from a single primitive, along with an envelope, -- trace, subdiagram map, and query function.-mkQD :: Prim b v -> Envelope v -> Trace v -> SubMap b v m -> Query v m -> QDiagram b v m-mkQD p e t n q- = QD $ D.leaf (toDeletable e *: toDeletable t *: toDeletable n *: q *: ()) p+mkQD :: Prim b v -> Envelope v -> Trace v -> SubMap b v m -> Query v m+ -> QDiagram b v m+mkQD p = mkQD' (PrimLeaf p) +-- | Create a diagram from a generic QDiaLeaf, along with an envelope,+-- trace, subdiagram map, and query function.+mkQD' :: QDiaLeaf b v m -> Envelope v -> Trace v -> SubMap b v m -> Query v m+ -> QDiagram b v m+mkQD' l e t n q+ = QD $ D.leaf (toDeletable e *: toDeletable t *: toDeletable n *: q *: ()) l+ ------------------------------------------------------------ -- Instances ------------------------------------------------------------@@ -390,10 +460,13 @@ ---- Functor instance Functor (QDiagram b v) where- fmap f = (over QD . D.mapU . second . second)- ( (first . fmap . fmap . fmap) f+ fmap f = over unwrapped+ ( (D.mapU . second . second)+ ( (first . fmap . fmap . fmap) f . (second . first . fmap . fmap) f )+ . (fmap . fmap) f+ ) ---- Applicative @@ -416,7 +489,7 @@ instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => HasStyle (QDiagram b v m) where- applyStyle = over QD . D.applyD . inj+ applyStyle = over unwrapped . D.applyD . inj . (inR :: Style v -> Split (Transformation v) :+: Style v) -- | By default, diagram attributes are not affected by@@ -435,29 +508,31 @@ -- produce a concrete drawing of the diagram, and it is this visual -- representation itself which is acted upon by subsequent -- transformations.-freeze :: forall v b m. (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m)+freeze :: forall v b m. (HasLinearMap v, InnerSpace v+ , OrderedField (Scalar v), Semigroup m) => QDiagram b v m -> QDiagram b v m-freeze = over QD . D.applyD . inj+freeze = over unwrapped . D.applyD . inj . (inL :: Split (Transformation v) -> Split (Transformation v) :+: Style v) $ split ---- Juxtaposable -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m)+instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) => Juxtaposable (QDiagram b v m) where juxtapose = juxtaposeDefault ---- Enveloped -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v) )+instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) => Enveloped (QDiagram b v m) where- getEnvelope = envelope+ getEnvelope = view envelope ---- Traced -instance (HasLinearMap v, VectorSpace v, Ord (Scalar v))+instance (HasLinearMap v, VectorSpace v, Ord (Scalar v), InnerSpace v+ , Semigroup m, Fractional (Scalar v), Floating (Scalar v)) => Traced (QDiagram b v m) where- getTrace = trace+ getTrace = view trace ---- HasOrigin @@ -474,7 +549,7 @@ -- components appropriately. instance (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Semigroup m) => Transformable (QDiagram b v m) where- transform = over QD . D.applyD . transfToAnnot+ transform = over unwrapped . D.applyD . transfToAnnot ---- Qualifiable @@ -482,7 +557,7 @@ -- now be referred to using the qualification prefix. instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => Qualifiable (QDiagram b v m) where- (|>) = over QD . D.applyD . inj . toName+ (|>) = over unwrapped . D.applyD . inj . toName ------------------------------------------------------------@@ -517,11 +592,11 @@ instance Functor (Subdiagram b v) where fmap f (Subdiagram d a) = Subdiagram (fmap f d) a -instance (OrderedField (Scalar v), InnerSpace v, HasLinearMap v)+instance (OrderedField (Scalar v), InnerSpace v, HasLinearMap v, Monoid' m) => Enveloped (Subdiagram b v m) where getEnvelope (Subdiagram d a) = transform (transfFromAnnot a) $ getEnvelope d -instance (Ord (Scalar v), VectorSpace v, HasLinearMap v)+instance (OrderedField (Scalar v), HasLinearMap v, InnerSpace v, Semigroup m) => Traced (Subdiagram b v m) where getTrace (Subdiagram d a) = transform (transfFromAnnot a) $ getTrace d @@ -551,7 +626,7 @@ , Semigroup m ) => Subdiagram b v m -> QDiagram b v m-getSub (Subdiagram d a) = over QD (D.applyD a) d+getSub (Subdiagram d a) = over unwrapped (D.applyD a) d -- | Extract the \"raw\" content of a subdiagram, by throwing away the -- context.@@ -567,9 +642,11 @@ newtype SubMap b v m = SubMap (M.Map Name [Subdiagram b v m]) -- See Note [SubMap Set vs list] -instance Newtype (SubMap b v m) (M.Map Name [Subdiagram b v m]) where- pack = SubMap- unpack (SubMap m) = m+instance Wrapped+ (M.Map Name [Subdiagram b v m])+ (M.Map Name [Subdiagram b v m'])+ (SubMap b v m) (SubMap b v m')+ where wrapped = iso SubMap (\(SubMap m) -> m) -- ~~~~ [SubMap Set vs list] -- In some sense it would be nicer to use@@ -579,7 +656,7 @@ type instance V (SubMap b v m) = v instance Functor (SubMap b v) where- fmap = over SubMap . fmap . map . fmap+ fmap = over unwrapped . fmap . map . fmap instance Semigroup (SubMap b v m) where SubMap s1 <> SubMap s2 = SubMap $ M.unionWith (++) s1 s2@@ -595,11 +672,11 @@ instance (OrderedField (Scalar v), InnerSpace v, HasLinearMap v) => HasOrigin (SubMap b v m) where- moveOriginTo = over SubMap . moveOriginTo+ moveOriginTo = over unwrapped . moveOriginTo instance (InnerSpace v, Floating (Scalar v), HasLinearMap v) => Transformable (SubMap b v m) where- transform = over SubMap . transform+ transform = over unwrapped . transform -- | 'SubMap's are qualifiable: if @ns@ is a 'SubMap', then @a |> -- ns@ is the same 'SubMap' except with every name qualified by@@ -614,7 +691,7 @@ -- | Add a name/diagram association to a submap. rememberAs :: IsName a => a -> QDiagram b v m -> SubMap b v m -> SubMap b v m-rememberAs n b = over SubMap $ M.insertWith (++) (toName n) [mkSubdiagram b]+rememberAs n b = over unwrapped $ M.insertWith (++) (toName n) [mkSubdiagram b] -- | A name acts on a name map by qualifying every name in it. instance Action Name (SubMap b v m) where@@ -636,10 +713,10 @@ lookupSub :: IsName n => n -> SubMap b v m -> Maybe [Subdiagram b v m] lookupSub a (SubMap m) = M.lookup n m `mplus`- (flatten . filter ((n `nameSuffixOf`) . fst) . M.assocs $ m)+ (flattenNames . filter ((n `nameSuffixOf`) . fst) . M.assocs $ m) where (Name n1) `nameSuffixOf` (Name n2) = n1 `isSuffixOf` n2- flatten [] = Nothing- flatten xs = Just . concatMap snd $ xs+ flattenNames [] = Nothing+ flattenNames xs = Just . concatMap snd $ xs n = toName a ------------------------------------------------------------@@ -704,13 +781,64 @@ -- Backends ----------------------------------------------- ------------------------------------------------------------ +data DNode b v a = DStyle (Style v)+ | DTransform (Split (Transformation v))+ | DAnnot a+ | DDelay+ -- ^ @DDelay@ marks a point where a delayed subtree+ -- was expanded. Such subtrees already take all+ -- non-frozen transforms above them into account,+ -- so when later processing the tree, upon+ -- encountering a @DDelay@ node we must drop any+ -- accumulated non-frozen transformation.+ | DPrim (Prim b v)+ | DEmpty++-- | A 'DTree' is a raw tree representation of a 'QDiagram', with all+-- the @u@-annotations removed. It is used as an intermediate type+-- by diagrams-core; backends should not need to make use of it.+-- Instead, backends can make use of 'RTree', which 'DTree' gets+-- compiled and optimized to.+type DTree b v a = Tree (DNode b v a)++data RNode b v a = RStyle (Style v)+ -- ^ A style node.+ | RFrozenTr (Transformation v)+ -- ^ A \"frozen\" transformation, /i.e./ one which+ -- was applied after a call to 'freeze'. It+ -- applies to everything below it in the tree.+ -- Note that line width and other similar+ -- \"scale invariant\" attributes should be+ -- affected by this transformation. In the case+ -- of 2D, some backends may not support stroking+ -- in the context of an arbitrary+ -- transformation; such backends can instead use+ -- the 'avgScale' function from+ -- "Diagrams.TwoD.Transform" (from the+ -- @diagrams-lib@ package).+ | RAnnot a+ | RPrim (Transformation v) (Prim b v)+ -- ^ A primitive, along with the (non-frozen)+ -- transformation which applies to it.+ | REmpty++-- | An 'RTree' is a compiled and optimized representation of a+-- 'QDiagram', which can be used by backends. They have several+-- invariants which backends may rely upon:+--+-- * All non-frozen transformations have been pushed all the way to+-- the leaves.+--+-- * @RPrim@ nodes never have any children.+type RTree b v a = Tree (RNode b v a )+ -- | Abstract diagrams are rendered to particular formats by -- /backends/. Each backend/vector space combination must be an -- instance of the 'Backend' class. A minimal complete definition--- consists of the three associated types and implementations for--- 'withStyle' and 'doRender'.---+-- consists of the three associated types, an implementation for+-- 'doRender', and /one of/ either 'withStyle' or 'renderData'. class (HasLinearMap v, Monoid (Render b v)) => Backend b v where+ -- | The type of rendering operations used by this backend, which -- must be a monoid. For example, if @Render b v = M ()@ for some -- monad @M@, a monoid instance can be made with @mempty = return@@ -723,12 +851,24 @@ -- | Backend-specific rendering options. data Options b v :: * - -- | Perform a rendering operation with a local style.+ -- | Perform a rendering operation with a local style. The default+ -- implementation does nothing, and must be overridden by backends+ -- that do not override 'renderData'. withStyle :: b -- ^ Backend token (needed only for type inference) -> Style v -- ^ Style to use- -> Transformation v -- ^ Transformation to be applied to the style+ -> Transformation v+ -- ^ \"Frozen\" transformation; line width and+ -- other similar \"scale invariant\" attributes+ -- should be affected by this transformation.+ -- In the case of 2D, some backends may not+ -- support stroking in the context of an+ -- arbitrary transformation; such backends can+ -- instead use the 'avgScale' function from+ -- "Diagrams.TwoD.Transform" (from the+ -- @diagrams-lib@ package). -> Render b v -- ^ Rendering operation to run -> Render b v -- ^ Rendering operation using the style locally+ withStyle _ _ _ r = r -- | 'doRender' is used to interpret rendering operations. doRender :: b -- ^ Backend token (needed only for type inference)@@ -747,27 +887,25 @@ -> QDiagram b v m -> (Options b v, QDiagram b v m) adjustDia _ o d = (o,d) - -- XXX expand this comment. Explain about freeze, split- -- transformations, etc.- -- | Render a diagram. This has a default implementation in terms- -- of 'adjustDia', 'withStyle', 'doRender', and the 'render'- -- operation from the 'Renderable' class (first 'adjustDia' is- -- used, then 'withStyle' and 'render' are used to render each- -- primitive, the resulting operations are combined with- -- 'mconcat', and the final operation run with 'doRender') but- -- backends may override it if desired. renderDia :: (InnerSpace v, OrderedField (Scalar v), Monoid' m) => b -> Options b v -> QDiagram b v m -> Result b v- renderDia b opts d =- doRender b opts' . mconcat . map renderOne . prims $ d'- where (opts', d') = adjustDia b opts d- renderOne :: (Prim b v, (Split (Transformation v), Style v))- -> Render b v- renderOne (p, (M t, s))- = withStyle b s mempty (render b (transform t p))+ renderDia b opts d = doRender b opts' . renderData b $ d'+ where (opts', d') = adjustDia b opts d - renderOne (p, (t1 :| t2, s))- = withStyle b s t1 (render b (transformWithFreeze t1 t2 p))+ -- | Backends may override 'renderData' to gain more control over+ -- the way that rendering happens. A typical implementation might be something like+ --+ -- > renderData = renderRTree . toRTree+ --+ -- where @renderRTree :: RTree b v () -> Render b v@ is+ -- implemented by the backend (with appropriate types filled in+ -- for @b@ and @v@), and 'toRTree' is from "Diagrams.Core.Compile".+ renderData :: Monoid' m => b -> QDiagram b v m -> Render b v+ renderData b = mconcat . map renderOne . prims+ where+ renderOne :: (Prim b v, (Split (Transformation v), Style v)) -> Render b v+ renderOne (p, (M t, s)) = withStyle b s mempty (render b (transform t p))+ renderOne (p, (t1 :| t2, s)) = withStyle b s t1 (render b (transformWithFreeze t1 t2 p)) -- See Note [backend token]
src/Diagrams/Core/V.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- |--- Module : Diagrams.Core.MList+-- Module : Diagrams.Core.V -- Copyright : (c) 2011 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com