diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -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) --------------------------- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -3,6 +3,9 @@ Daniel Bergey Conal Elliott Sam Griffin + Chris Mears + Jeffrey Rosenbluth + Carlos Scheidegger Vilhelm Sjöberg Michael Sloan Scott Walck diff --git a/diagrams-core.cabal b/diagrams-core.cabal --- a/diagrams-core.cabal +++ b/diagrams-core.cabal @@ -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 diff --git a/src/Diagrams/Core.hs b/src/Diagrams/Core.hs --- a/src/Diagrams/Core.hs +++ b/src/Diagrams/Core.hs @@ -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 diff --git a/src/Diagrams/Core/Compile.hs b/src/Diagrams/Core/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Compile.hs @@ -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 diff --git a/src/Diagrams/Core/Envelope.hs b/src/Diagrams/Core/Envelope.hs --- a/src/Diagrams/Core/Envelope.hs +++ b/src/Diagrams/Core/Envelope.hs @@ -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 -- . See also Brent Yorgey, /Monoids: Theme and Variations/, published in the 2012 Haskell Symposium: ; video: . -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 diff --git a/src/Diagrams/Core/Juxtapose.hs b/src/Diagrams/Core/Juxtapose.hs --- a/src/Diagrams/Core/Juxtapose.hs +++ b/src/Diagrams/Core/Juxtapose.hs @@ -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) diff --git a/src/Diagrams/Core/Names.hs b/src/Diagrams/Core/Names.hs --- a/src/Diagrams/Core/Names.hs +++ b/src/Diagrams/Core/Names.hs @@ -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 .> diff --git a/src/Diagrams/Core/Query.hs b/src/Diagrams/Core/Query.hs --- a/src/Diagrams/Core/Query.hs +++ b/src/Diagrams/Core/Query.hs @@ -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, . 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 diff --git a/src/Diagrams/Core/Style.hs b/src/Diagrams/Core/Style.hs --- a/src/Diagrams/Core/Style.hs +++ b/src/Diagrams/Core/Style.hs @@ -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 diff --git a/src/Diagrams/Core/Trace.hs b/src/Diagrams/Core/Trace.hs --- a/src/Diagrams/Core/Trace.hs +++ b/src/Diagrams/Core/Trace.hs @@ -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 _ = "" @@ -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 diff --git a/src/Diagrams/Core/Transform.hs b/src/Diagrams/Core/Transform.hs --- a/src/Diagrams/Core/Transform.hs +++ b/src/Diagrams/Core/Transform.hs @@ -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 diff --git a/src/Diagrams/Core/Types.hs b/src/Diagrams/Core/Types.hs --- a/src/Diagrams/Core/Types.hs +++ b/src/Diagrams/Core/Types.hs @@ -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] diff --git a/src/Diagrams/Core/V.hs b/src/Diagrams/Core/V.hs --- a/src/Diagrams/Core/V.hs +++ b/src/Diagrams/Core/V.hs @@ -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