diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,35 @@ +1.1 (8 March 2014) +------------------ + +* **New features** + + - New `basis` function + - New `determinant` function for computing the determinant of a + `Transformation` + - Add `Typeable` constraint on `Prim`s, making it possible to + extract things back out of a `Prim` wrapper using `cast` + - Raw `Trace`s now return a *sorted list* of intersections, + instead of only the smallest. This is used to implement a new + family of functions `rayTraceV`, `rayTraceP`, `maxRayTraceV`, + `maxRayTraceP`, which work similarly to the parallel versions + without `Ray`, but return the first intersection in the + *positive* direction from the given point, rather than the + smallest in absolute terms. + - New `Annotation` type and corresponding `applyAnnotation` + function, for attaching uninterpreted annotations at specific + points in a diagram tree. Currently this is used for + hyperlinks; more annotation types will be added in the future. + +* **Dependency/version changes** + + - Require `lens-4.0` + - Allow `vector-space-points-0.2` + +* **Bug fixes** + + - Looking up a subdiagram by name now results in a diagram which + still has that name (#43) + 1.0.0.1 (27 November 2013) -------------------------- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,7 @@ -Copyright (c) 2011-2013 diagrams-core team: +Copyright (c) 2011-2014 diagrams-core team: Daniel Bergey + Tad Doxsee Conal Elliott Sam Griffin Chris Mears 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: 1.0.0.1 +Version: 1.1 Synopsis: Core libraries for diagrams EDSL Description: The core modules underlying diagrams, an embedded domain-specific language @@ -13,8 +13,9 @@ Category: Graphics Build-type: Simple Cabal-version: >=1.10 -Extra-source-files: CHANGES.markdown, README.markdown -Tested-with: GHC == 7.4.2, GHC == 7.6.1 +Extra-source-files: CHANGES.markdown, README.markdown, diagrams/*.svg +extra-doc-files: diagrams/*.svg +Tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.1 Source-repository head type: git location: git://github.com/diagrams/diagrams-core.git @@ -35,15 +36,15 @@ Diagrams.Core.Query Build-depends: base >= 4.2 && < 4.8, - containers >= 0.3 && < 0.6, - semigroups >= 0.3.4 && < 0.13, + containers >= 0.4.2 && < 0.6, + semigroups >= 0.8.4 && < 0.13, vector-space >= 0.8.4 && < 0.9, - vector-space-points >= 0.1 && < 0.2, + vector-space-points >= 0.1 && < 0.3, MemoTrie >= 0.4.7 && < 0.7, newtype >= 0.2 && < 0.3, monoid-extras >= 0.3 && < 0.4, dual-tree >= 0.2 && < 0.3, - lens >= 3.8 && < 4 + lens >= 4.0 && < 4.1 hs-source-dirs: src diff --git a/diagrams/src_Diagrams_Core_Trace_maxRayTracePEx.svg b/diagrams/src_Diagrams_Core_Trace_maxRayTracePEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_maxRayTracePEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Core_Trace_maxRayTraceVEx.svg b/diagrams/src_Diagrams_Core_Trace_maxRayTraceVEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_maxRayTraceVEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Core_Trace_maxTracePEx.svg b/diagrams/src_Diagrams_Core_Trace_maxTracePEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_maxTracePEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Core_Trace_maxTraceVEx.svg b/diagrams/src_Diagrams_Core_Trace_maxTraceVEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_maxTraceVEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Core_Trace_rayTracePEx.svg b/diagrams/src_Diagrams_Core_Trace_rayTracePEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_rayTracePEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Core_Trace_rayTraceVEx.svg b/diagrams/src_Diagrams_Core_Trace_rayTraceVEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_rayTraceVEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Core_Trace_traceEx.svg b/diagrams/src_Diagrams_Core_Trace_traceEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_traceEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Core_Trace_tracePEx.svg b/diagrams/src_Diagrams_Core_Trace_tracePEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_tracePEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Core_Trace_traceVEx.svg b/diagrams/src_Diagrams_Core_Trace_traceVEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_traceVEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/src/Diagrams/Core.hs b/src/Diagrams/Core.hs --- a/src/Diagrams/Core.hs +++ b/src/Diagrams/Core.hs @@ -9,7 +9,7 @@ -- domain-specific language for describing and rendering diagrams. -- Normal users of the diagrams library should almost never need to -- import anything from this package directly; instead, import modules --- (especially "Diagrams.Prelude") from the diagrams-lib package, +-- (especially @Diagrams.Prelude@) from the diagrams-lib package, -- which re-exports most things of value to users. -- -- For most library code needing access to core internals, it should @@ -32,6 +32,10 @@ -- * Transformations + -- ** Utilities + , basis + , determinant + -- ** Invertible linear transformations , (:-:), (<->), linv, lapp @@ -88,10 +92,13 @@ -- * Traces , Trace(Trace) + , SortedList, mkSortedList, getSortedList , appTrace, mkTrace , Traced(..) , traceV, traceP , maxTraceV, maxTraceP + , rayTraceV, rayTraceP + , maxRayTraceV, maxRayTraceP -- * Things with local origins @@ -121,6 +128,8 @@ , withNameAll , withNames , localize + + , href , freeze, setEnvelope, setTrace diff --git a/src/Diagrams/Core/Compile.hs b/src/Diagrams/Core/Compile.hs --- a/src/Diagrams/Core/Compile.hs +++ b/src/Diagrams/Core/Compile.hs @@ -39,7 +39,7 @@ emptyDTree = Node DEmpty [] -- | Convert a @QDiagram@ into a raw tree. -toDTree :: HasLinearMap v => QDiagram b v m -> Maybe (DTree b v ()) +toDTree :: HasLinearMap v => QDiagram b v m -> Maybe (DTree b v Annotation) toDTree (QD qd) = foldDUAL @@ -90,10 +90,10 @@ -- 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 :: HasLinearMap v => DTree b v Annotation -> RTree b v Annotation fromDTree = fromDTree' mempty where - fromDTree' :: HasLinearMap v => Transformation v -> DTree b v () -> RTree b v () + fromDTree' :: HasLinearMap v => Transformation v -> DTree b v Annotation -> RTree b v Annotation -- We put the accumulated unfrozen transformation (accTr) and the prim -- into an RPrim node. fromDTree' accTr (Node (DPrim p) _) @@ -113,18 +113,20 @@ fromDTree' accTr (Node (DTransform (tr1 :| tr2)) ts) = Node (RFrozenTr (accTr <> tr1)) (fmap (fromDTree' tr2) 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 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. + -- DEmpty nodes become REmpties, 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 :: HasLinearMap v => QDiagram b v m -> RTree b v Annotation 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 @@ -43,7 +43,8 @@ ) where import Control.Applicative ((<$>)) -import Control.Lens (Wrapped(..), iso, view, over, mapped, unwrapped) +import Control.Lens (Wrapped(..), Rewrapped, iso, over, mapped + , _Wrapping', op) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Semigroup @@ -96,18 +97,17 @@ -- . See also Brent Yorgey, /Monoids: Theme and Variations/, published in the 2012 Haskell Symposium: ; video: . newtype Envelope v = Envelope (Option (v -> Max (Scalar v))) -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) +instance Wrapped (Envelope v) where + type Unwrapped (Envelope v) = Option (v -> Max (Scalar v)) + _Wrapped' = iso (\(Envelope e) -> e) Envelope +instance Rewrapped (Envelope v) (Envelope v') + 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 = over (unwrapped . mapped) ((Max .) . t . (getMax .)) +onEnvelope t = over (_Wrapping' Envelope . mapped) ((Max .) . t . (getMax .)) mkEnvelope :: (v -> Scalar v) -> Envelope v mkEnvelope = Envelope . Option . Just . (Max .) @@ -188,7 +188,7 @@ getEnvelope p = moveTo p . mkEnvelope $ const zeroV instance Enveloped t => Enveloped (TransInv t) where - getEnvelope = getEnvelope . view unwrapped + getEnvelope = getEnvelope . op TransInv 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/HasOrigin.hs b/src/Diagrams/Core/HasOrigin.hs --- a/src/Diagrams/Core/HasOrigin.hs +++ b/src/Diagrams/Core/HasOrigin.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE FlexibleInstances - , FlexibleContexts - , TypeFamilies - , UndecidableInstances - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- The UndecidableInstances flag is needed under 6.12.3 for the -- HasOrigin (a,b) instance. @@ -23,10 +22,10 @@ ( HasOrigin(..), moveOriginBy, moveTo, place ) where -import qualified Data.Map as M -import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.Set as S -import Data.AffineSpace ((.-^), (.-.)) +import Data.AffineSpace ((.-.), (.-^)) import Data.VectorSpace import Diagrams.Core.Points @@ -40,7 +39,9 @@ -- having a separate class for 'HasOrigin'; indeed, for types which -- are instances of both we should have the identity -- --- > moveOriginTo (origin .^+ v) === translate (negateV v) +-- @ +-- moveOriginTo (origin .^+ v) === translate (negateV v) +-- @ -- -- The reason is that some things (e.g. vectors, 'Trail's) are -- transformable but are translationally invariant, i.e. have no @@ -63,12 +64,16 @@ -- the given point. Note that this is dual to 'moveOriginTo', i.e. we -- should have -- --- > moveTo (origin .^+ v) === moveOriginTo (origin .^- v) +-- @ +-- moveTo (origin .^+ v) === moveOriginTo (origin .^- v) +-- @ -- -- For types which are also 'Transformable', this is essentially the -- same as 'translate', i.e. -- --- > moveTo (origin .^+ v) === translate v +-- @ +-- moveTo (origin .^+ v) === translate v +-- @ moveTo :: HasOrigin t => Point (V t) -> t -> t moveTo = moveOriginBy . (origin .-.) 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 @@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | @@ -31,7 +32,7 @@ ) where -import Control.Lens (over, unwrapped, Wrapped(..), iso) +import Control.Lens (over, Wrapped(..), Rewrapped, iso, _Unwrapping') import Data.List (intercalate) import qualified Data.Map as M import Data.Semigroup @@ -92,9 +93,12 @@ newtype Name = Name [AName] deriving (Eq, Ord, Semigroup, Monoid, Typeable) -instance Wrapped [AName] [AName] Name Name - where wrapped = iso Name (\(Name ans) -> ans) +instance Wrapped Name where + type Unwrapped Name = [AName] + _Wrapped' = iso (\(Name ans) -> ans) Name +instance Rewrapped Name Name + instance Show Name where show (Name ns) = intercalate " .> " $ map show ns @@ -118,7 +122,7 @@ (|>) = (.>) instance Qualifiable a => Qualifiable (TransInv a) where - (|>) n = over unwrapped (n |>) + (|>) n = over (_Unwrapping' TransInv) (n |>) instance (Qualifiable a, Qualifiable b) => Qualifiable (a,b) where n |> (a,b) = (n |> a, n |> b) 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 @@ -21,7 +21,7 @@ ) where import Control.Applicative -import Control.Lens (Wrapped(..), iso) +import Control.Lens (Wrapped(..), Rewrapped, iso) import Data.Semigroup import Data.AffineSpace @@ -45,8 +45,11 @@ 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 +instance Wrapped (Query v m) where + type Unwrapped (Query v m) = (Point v -> m) + _Wrapped' = iso runQuery Query + +instance Rewrapped (Query v m) (Query v' m') 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 @@ -44,7 +44,7 @@ ) where import Control.Arrow ((***)) -import Control.Lens (Wrapped(..), iso) +import Control.Lens (Wrapped(..), Rewrapped, iso) import qualified Data.Map as M import Data.Semigroup import qualified Data.Set as S @@ -140,12 +140,11 @@ -- 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) +instance Wrapped (Style v) where + type Unwrapped (Style v) = M.Map String (Attribute v) + _Wrapped' = iso (\(Style m) -> m) Style + +instance Rewrapped (Style v) (Style v') 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 @@ -25,9 +25,13 @@ ----------------------------------------------------------------------------- module Diagrams.Core.Trace - ( -- * Traces - Trace(Trace) + ( -- * SortedList + SortedList + , mkSortedList, getSortedList, onSortedList, unsafeOnSortedList + -- * Traces + , Trace(Trace) + , appTrace , mkTrace @@ -39,17 +43,20 @@ , traceV, traceP , maxTraceV, maxTraceP + , getRayTrace + , rayTraceV, rayTraceP + , maxRayTraceV, maxRayTraceP ) where import Control.Applicative import Control.Lens +import Data.List (sort) import qualified Data.Map as M import Data.Semigroup import qualified Data.Set as S import Data.AffineSpace -import Data.Monoid.Inf import Data.VectorSpace import Diagrams.Core.HasOrigin @@ -58,52 +65,104 @@ import Diagrams.Core.V ------------------------------------------------------------ +-- SortedList -------------------------------------------- +------------------------------------------------------------ + +-- Traces return sorted lists of intersections, so we define a newtype +-- wrapper to represent sorted lists. + +-- | A newtype wrapper around a list which maintains the invariant +-- that the list is sorted. The constructor is not exported; use +-- the smart constructor 'mkSortedList' (which sorts the given list) +-- instead. +newtype SortedList a = SortedList [a] + +-- | A smart constructor for the 'SortedList' type, which sorts the +-- input to ensure the 'SortedList' invariant. +mkSortedList :: Ord a => [a] -> SortedList a +mkSortedList = SortedList . sort + +-- | Project the (guaranteed sorted) list out of a 'SortedList' +-- wrapper. +getSortedList :: SortedList a -> [a] +getSortedList (SortedList as) = as + +-- | Apply a list function to a 'SortedList'. The function need not +-- result in a sorted list; the result will be sorted before being +-- rewrapped as a 'SortedList'. +onSortedList :: Ord b => ([a] -> [b]) -> (SortedList a -> SortedList b) +onSortedList f = unsafeOnSortedList (sort . f) + +-- | Apply an /order-preserving/ list function to a 'SortedList'. No +-- sorts or checks are done. +unsafeOnSortedList :: ([a] -> [b]) -> (SortedList a -> SortedList b) +unsafeOnSortedList f (SortedList as) = SortedList (f as) + +-- | Merge two sorted lists. The result is the sorted list containing +-- all the elements of both input lists (with duplicates). +merge :: Ord a => SortedList a -> SortedList a -> SortedList a +merge (SortedList as) (SortedList bs) = SortedList (merge' as bs) + where + merge' xs [] = xs + merge' [] ys = ys + merge' (x:xs) (y:ys) = + if x <= y + then x : merge' xs (y:ys) + else y : merge' (x:xs) ys + +-- | 'SortedList' forms a semigroup with 'merge' as composition. +instance Ord a => Semigroup (SortedList a) where + (<>) = merge + +-- | 'SortedList' forms a monoid with 'merge' and the empty list. +instance Ord a => Monoid (SortedList a) where + mappend = (<>) + mempty = SortedList [] + +------------------------------------------------------------ -- Trace ------------------------------------------------- ------------------------------------------------------------ +-- > traceEx = mkTraceDia def + -- | Every diagram comes equipped with a /trace/. Intuitively, the -- trace for a diagram is like a raytracer: given a line --- (represented as a base point and a direction), the trace computes --- the distance from the base point along the line to the first --- intersection with the diagram. The distance can be negative if --- the intersection is in the opposite direction from the base --- point, or infinite if the ray never intersects the diagram. --- Note: to obtain the distance to the /furthest/ intersection --- instead of the /closest/, just negate the direction vector and --- then negate the result. +-- (represented as a base point and a direction vector), the trace +-- computes a sorted list of signed distances from the base point to +-- all intersections of the line with the boundary of the +-- diagram. -- --- Note that the output should actually be interpreted not as an --- absolute distance, but as a multiplier relative to the input --- vector. That is, if the input vector is @v@ and the returned --- scalar is @s@, the distance from the base point to the --- intersection is given by @s * magnitude v@. +-- Note that the outputs are not absolute distances, but multipliers +-- relative to the input vector. That is, if the base point is @p@ +-- and direction vector is @v@, and one of the output scalars is +-- @s@, then there is an intersection at the point @p .+^ (s *^ v)@. +-- +-- <> -newtype Trace v = Trace { appTrace :: Point v -> v -> PosInf (Scalar v) } +newtype Trace v = Trace { appTrace :: Point v -> v -> SortedList (Scalar v) } -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 +instance Wrapped (Trace v) where + type Unwrapped (Trace v) = Point v -> v -> SortedList (Scalar v) + _Wrapped' = iso appTrace Trace -mkTrace :: (Point v -> v -> PosInf (Scalar v)) -> Trace v +instance Rewrapped (Trace v) (Trace v') + +mkTrace :: (Point v -> v -> SortedList (Scalar v)) -> Trace v mkTrace = Trace -- | Traces form a semigroup with pointwise minimum as composition. -- Hence, if @t1@ is the trace for diagram @d1@, and -- @e2@ is the trace for @d2@, then @e1 \`mappend\` e2@ -- is the trace for @d1 \`atop\` d2@. -deriving instance Ord (Scalar v) => Semigroup (Trace v) --- | The identity for the 'Monoid' instance is the constantly infinite --- trace. -deriving instance Ord (Scalar v) => Monoid (Trace v) +deriving instance (Ord (Scalar v)) => Semigroup (Trace v) +deriving instance (Ord (Scalar v)) => Monoid (Trace v) + type instance V (Trace v) = v instance (VectorSpace v) => HasOrigin (Trace v) where - moveOriginTo (P u) = unwrapping Trace %~ \f p -> f (p .+^ u) + moveOriginTo (P u) = (_Wrapping' Trace) %~ \f p -> f (p .+^ u) instance Show (Trace v) where show _ = "" @@ -113,7 +172,7 @@ ------------------------------------------------------------ instance HasLinearMap v => Transformable (Trace v) where - transform t = unwrapped %~ \f p v -> f (papply (inv t) p) (apply (inv t) v) + transform t = _Wrapped' %~ \f p v -> f (papply (inv t) p) (apply (inv t) v) ------------------------------------------------------------ -- Traced class ------------------------------------------ @@ -129,17 +188,16 @@ getTrace = id -- | The trace of a single point is the empty trace, /i.e./ the one --- which returns positive infinity for every query. Arguably it --- should return a finite distance for vectors aimed directly at the --- given point and infinity for everything else, but due to --- floating-point inaccuracy this is problematic. Note that the --- envelope for a single point is /not/ the empty envelope (see --- "Diagrams.Core.Envelope"). +-- which returns no intersection points for every query. Arguably +-- it should return a single finite distance for vectors aimed +-- directly at the given point, but due to floating-point inaccuracy +-- this is problematic. Note that the 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 = const mempty instance Traced t => Traced (TransInv t) where - getTrace = getTrace . view unwrapped + getTrace = getTrace . op TransInv instance (Traced a, Traced b, V a ~ V b) => Traced (a,b) where getTrace (x,y) = getTrace x <> getTrace y @@ -157,26 +215,211 @@ -- Computing with traces --------------------------------- ------------------------------------------------------------ --- | Compute the vector from the given point to the boundary of the --- given object in the given direction, or @Nothing@ if there is no --- intersection. +-- | Compute the vector from the given point @p@ to the \"smallest\" +-- boundary intersection along the given vector @v@. The +-- \"smallest\" boundary intersection is defined as the one given by +-- @p .+^ (s *^ v)@ for the smallest (most negative) value of +-- @s@. Return @Nothing@ if there is no intersection. See also +-- 'traceP'. +-- +-- See also 'rayTraceV' which uses the smallest /positive/ +-- intersection, which is often more intuitive behavior. +-- +-- <> traceV :: Traced a => Point (V a) -> V a -> a -> Maybe (V a) -traceV p v a = case ((getTrace a)^.unwrapping Trace) p v of - Finite s -> Just (s *^ v) - Infinity -> Nothing +traceV p v a = case getSortedList $ op Trace (getTrace a) p v of + (s:_) -> Just (s *^ v) + [] -> Nothing --- | Given a base point and direction, compute the closest point on --- the boundary of the given object, or @Nothing@ if there is no --- intersection in the given direction. +-- > traceVEx = mkTraceDiasABC def { drawV = True, sFilter = take 1 } + + +-- | Compute the \"smallest\" boundary point along the line determined +-- by the given point @p@ and vector @v@. The \"smallest\" boundary +-- point is defined as the one given by @p .+^ (s *^ v)@ for +-- the smallest (most negative) value of @s@. Return @Nothing@ if +-- there is no such boundary point. See also 'traceV'. +-- +-- See also 'rayTraceP' which uses the smallest /positive/ +-- intersection, which is often more intuitive behavior. +-- +-- <> traceP :: Traced a => Point (V a) -> V a -> a -> Maybe (Point (V a)) traceP p v a = (p .+^) <$> traceV p v a --- | Like 'traceV', but computes a vector to the *furthest* point on --- the boundary instead of the closest. +-- > tracePEx = mkTraceDiasABC def { sFilter = take 1 } + + +-- | Like 'traceV', but computes a vector to the \"largest\" boundary +-- point instead of the smallest. (Note, however, the \"largest\" +-- boundary point may still be in the opposite direction from the +-- given vector, if all the boundary points are, as in the third +-- example shown below.) +-- +-- <> maxTraceV :: Traced a => Point (V a) -> V a -> a -> Maybe (V a) maxTraceV p = traceV p . negateV --- | Like 'traceP', but computes the *furthest* point on the boundary --- instead of the closest. +-- > maxTraceVEx = mkTraceDiasABC def { drawV = True, sFilter = dropAllBut1 } + + +-- | Like 'traceP', but computes the \"largest\" boundary point +-- instead of the smallest. (Note, however, the \"largest\" boundary +-- point may still be in the opposite direction from the given +-- vector, if all the boundary points are.) +-- +-- <> maxTraceP :: Traced a => Point (V a) -> V a -> a -> Maybe (Point (V a)) maxTraceP p v a = (p .+^) <$> maxTraceV p v a + +-- > maxTracePEx = mkTraceDiasABC def { sFilter = dropAllBut1 } + + +-- | Get a modified 'Trace' for an object which only returns positive +-- boundary points, /i.e./ those boundary points given by a positive +-- scalar multiple of the direction vector. Note, this property +-- will be destroyed if the resulting 'Trace' is translated at all. +getRayTrace :: (Traced a, Num (Scalar (V a))) => a -> Trace (V a) +getRayTrace a = Trace $ \p v -> unsafeOnSortedList (dropWhile (<0)) $ appTrace (getTrace a) p v + +-- | Compute the vector from the given point to the closest boundary +-- point of the given object in the given direction, or @Nothing@ if +-- there is no such boundary point (as in the third example +-- below). Note that unlike 'traceV', only /positive/ boundary +-- points are considered, /i.e./ boundary points corresponding to a +-- positive scalar multiple of the direction vector. This is +-- intuitively the \"usual\" behavior of a raytracer, which only +-- considers intersections \"in front of\" the camera. Compare the +-- second example diagram below with the second example shown for +-- 'traceV'. +-- +-- <> +rayTraceV :: (Traced a, Num (Scalar (V a))) + => Point (V a) -> V a -> a -> Maybe (V a) +rayTraceV p v a = case getSortedList $ op Trace (getRayTrace a) p v of + (s:_) -> Just (s *^ v) + [] -> Nothing + +-- > rayTraceVEx = mkTraceDiasABC def { drawV = True, sFilter = take 1 . filter (>0) } + + +-- | Compute the boundary point on an object which is closest to the +-- given base point in the given direction, or @Nothing@ if there is +-- no such boundary point. Note that unlike 'traceP', only /positive/ +-- boundary points are considered, /i.e./ boundary points +-- corresponding to a positive scalar multiple of the direction +-- vector. This is intuitively the \"usual\" behavior of a raytracer, +-- which only considers intersection points \"in front of\" the +-- camera. +-- +-- <> +rayTraceP :: (Traced a, Num (Scalar (V a))) + => Point (V a) -> V a -> a -> Maybe (Point (V a)) +rayTraceP p v a = (p .+^) <$> rayTraceV p v a + +-- > rayTracePEx = mkTraceDiasABC def { sFilter = take 1 . filter (>0) } + + +-- | Like 'rayTraceV', but computes a vector to the \"largest\" +-- boundary point instead of the smallest. Considers only +-- /positive/ boundary points. +-- +-- <> +maxRayTraceV :: (Traced a, Num (Scalar (V a))) + => Point (V a) -> V a -> a -> Maybe (V a) +maxRayTraceV p v a = + case getSortedList $ op Trace (getRayTrace a) p v of + [] -> Nothing + xs -> Just ((last xs) *^ v) + +-- > maxRayTraceVEx = mkTraceDiasABC def { drawV = True, sFilter = dropAllBut1 . filter (>0) } + + +-- | Like 'rayTraceP', but computes the \"largest\" boundary point +-- instead of the smallest. Considers only /positive/ boundary +-- points. +-- +-- <> +maxRayTraceP :: (Traced a, Num (Scalar (V a))) + => Point (V a) -> V a -> a -> Maybe (Point (V a)) +maxRayTraceP p v a = (p .+^) <$> maxRayTraceV p v a + +-- > maxRayTracePEx = mkTraceDiasABC def { sFilter = dropAllBut1 . filter (>0) } + + +------------------------------------------------------------ +-- Drawing trace diagrams +------------------------------------------------------------ + +-- > import Data.Default.Class +-- > import Control.Lens ((^.)) +-- > import Data.Maybe (fromMaybe) +-- > +-- > thingyT :: Trail R2 +-- > thingyT = +-- > fromOffsets +-- > [ 3 *^ unitX, 3 *^ unitY, 2 *^ unit_X, 1 *^ unit_Y +-- > , 1 *^ unitX, 1 *^ unit_Y, 2 *^ unit_X, 1 *^ unit_Y ] +-- > +-- > thingy = strokeTrail thingyT +-- > +-- > data TraceDiaOpts +-- > = TDO { traceShape :: Diagram B R2 +-- > , basePt :: P2 +-- > , dirV :: R2 +-- > , sFilter :: [Double] -> [Double] +-- > , drawV :: Bool +-- > } +-- > +-- > instance Default TraceDiaOpts where +-- > def = TDO { traceShape = thingy +-- > , basePt = pointB +-- > , dirV = 0.3 ^& 0.5 +-- > , sFilter = id +-- > , drawV = False +-- > } +-- > +-- > pointA = 1 ^& (-1.5) +-- > pointB = 1 ^& 1.2 +-- > pointC = 2.5 ^& 3.5 +-- > +-- > dot = circle 0.05 # lw 0 +-- > +-- > mkTraceDia :: TraceDiaOpts -> Diagram B R2 +-- > mkTraceDia tdo = mconcat +-- > [ mconcat $ map (place (dot # fc red)) pts +-- > , if drawV tdo then resultArrow else mempty +-- > , arrowAt (basePt tdo) (dirV tdo) # lw 0.02 # lc blue +-- > , dot # fc blue # moveTo (basePt tdo) +-- > , traceLine (basePt tdo) maxPosPt +-- > , traceLine (basePt tdo) minNegPt +-- > , traceShape tdo +-- > ] +-- > # centerXY # pad 1.1 +-- > where +-- > ss = sFilter tdo . getSortedList +-- > $ appTrace (traceShape tdo ^. trace) (basePt tdo) (dirV tdo) +-- > pts = map mkPt ss +-- > mkPt s = basePt tdo .+^ (s *^ dirV tdo) +-- > maxPosPt = (mkPt <$>) . safeLast $ filter (>0) ss +-- > minNegPt = (mkPt <$>) . safeHead $ filter (<0) ss +-- > minPt = (mkPt <$>) . safeHead $ ss +-- > resultArrow = fromMaybe mempty (arrowBetween (basePt tdo) <$> minPt) +-- > # lw 0.03 # lc green +-- > +-- > safeLast [] = Nothing +-- > safeLast xs = Just $ last xs +-- > safeHead [] = Nothing +-- > safeHead (x:_) = Just x +-- > dropAllBut1 [] = [] +-- > dropAllBut1 xs = [last xs] +-- > +-- > traceLine _ Nothing = mempty +-- > traceLine p (Just q) = (p ~~ q) # dashing [0.1,0.1] 0 +-- > +-- > mkTraceDias :: [TraceDiaOpts] -> Diagram B R2 +-- > mkTraceDias = hcat' (with & sep .~ 1) . map mkTraceDia +-- > +-- > mkTraceDiasABC :: TraceDiaOpts -> Diagram B R2 +-- > mkTraceDiasABC tdo = mkTraceDias (map (\p -> tdo { basePt = p }) [pointA, pointB, pointC]) + 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 @@ -6,6 +6,7 @@ , MultiParamTypeClasses , GeneralizedNewtypeDeriving , TemplateHaskell + , TypeFamilies , TypeSynonymInstances , ScopedTypeVariables #-} @@ -39,7 +40,10 @@ , apply , papply , fromLinear + , basis , onBasis + , matrixRep + , determinant -- * The Transformable class @@ -60,7 +64,7 @@ ) where -import Control.Lens (Wrapped(..), iso) +import Control.Lens (Wrapped(..), Rewrapped, iso) import qualified Data.Map as M import Data.Semigroup import qualified Data.Set as S @@ -133,6 +137,9 @@ -- inverse transpose. This is exactly what we need when -- transforming bounding functions, which are defined in terms of -- /perpendicular/ (i.e. normal) hyperplanes. +-- +-- For more general, non-invertable transformations, see +-- @Diagrams.Deform@ (in @diagrams-lib@). data Transformation v = Transformation (v :-: v) (v :-: v) v @@ -183,20 +190,49 @@ fromLinear :: AdditiveGroup v => (v :-: v) -> (v :-: v) -> Transformation v fromLinear l1 l2 = Transformation l1 l2 zeroV +-- | Get the matrix equivalent of the basis of the vector space v as +-- a list of columns. +basis :: forall v. HasLinearMap v => [v] +basis = map basisValue b + where b = map fst (decompose (zeroV :: v)) -- | Get the matrix equivalent of the linear transform, -- (as a list of columns) and the translation vector. This -- is mostly useful for implementing backends. onBasis :: forall v. HasLinearMap v => Transformation v -> ([v], v) onBasis t = (vmat, tr) - where tr :: v - tr = transl t - basis :: [Basis v] - basis = map fst (decompose tr) - es :: [v] - es = map basisValue basis - vmat :: [v] - vmat = map (apply t) es + where + tr = transl t + vmat = map (apply t) basis +-- Remove the nth element from a list +remove :: Int -> [a] -> [a] +remove n xs = ys ++ (tail zs) + where + (ys, zs) = splitAt n xs + +-- Minor matrix of cofactore C(i,j) +minor :: Int -> Int -> [[a]] -> [[a]] +minor i j xs = remove j $ map (remove i) xs + +-- The determinant of a square matrix represented as a list of lists +-- representing column vectors, that is [column]. +det :: Num a => [[a]] -> a +det (a:[]) = head a +det m = sum [(-1)^i * (c1 !! i) * det (minor i 0 m) | i <- [0 .. (n-1)]] + where + c1 = head m + n = length m + +-- | Convert a `Transformation v` to a matrix representation as a list of +-- column vectors which are also lists. +matrixRep :: HasLinearMap v => Transformation v -> [[Scalar v]] +matrixRep t = map listRep (fst . onBasis $ t) + where listRep v = map snd (decompose v) + +-- | The determinant of a `Transformation`. +determinant :: (HasLinearMap v, Num (Scalar v)) => Transformation v -> Scalar v +determinant t = det . matrixRep $ t + ------------------------------------------------------------ -- The Transformable class ------------------------------- ------------------------------------------------------------ @@ -275,8 +311,11 @@ 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) +instance Wrapped (TransInv t) where + type Unwrapped (TransInv t) = t + _Wrapped' = iso (\(TransInv t) -> t) TransInv + +instance Rewrapped (TransInv t) (TransInv 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 @@ -45,7 +45,14 @@ -- * Diagrams -- ** Annotations - UpAnnots, DownAnnots, transfToAnnot, transfFromAnnot + + -- *** Static annotations + Annotation(Href) + , applyAnnotation, href + + -- *** Dynamic (monoidal) annotations + , UpAnnots, DownAnnots, transfToAnnot, transfFromAnnot + -- ** Basic type definitions , QDiaLeaf(..), withQDiaLeaf , QDiagram(..), Diagram @@ -118,8 +125,9 @@ ) where import Control.Arrow (first, second, (***)) -import Control.Lens (Lens', Wrapped (..), iso, lens, - over, unwrapped, view, (^.)) +import Control.Lens (Lens', Rewrapped, Wrapped (..), iso, + lens, over, view, (^.), _Wrapped, + _Wrapping) import Control.Monad (mplus) import Data.AffineSpace ((.-.)) import Data.List (isSuffixOf) @@ -230,21 +238,39 @@ withQDiaLeaf f _ (PrimLeaf p) = f p withQDiaLeaf _ g (DelayedLeaf d) = g d +-- | Static annotations which can be placed at a particular node of a +-- diagram tree. +data Annotation + = Href String -- ^ Hyperlink + deriving Show + +-- | Apply a static annotation at the root of a diagram. +applyAnnotation + :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) + => Annotation -> QDiagram b v m -> QDiagram b v m +applyAnnotation an (QD dt) = QD (D.annot an dt) + +-- | Make a diagram into a hyperlink. Note that only some backends +-- will honor hyperlink annotations. +href :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => String -> QDiagram b v m -> QDiagram b v m +href = applyAnnotation . Href + -- | 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 (D.DUALTree (DownAnnots v) (UpAnnots b v m) () (QDiaLeaf b v m)) + = QD (D.DUALTree (DownAnnots v) (UpAnnots b v m) Annotation (QDiaLeaf b v m)) deriving (Typeable) -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) +instance Wrapped (QDiagram b v m) where + type Unwrapped (QDiagram b v m) = + D.DUALTree (DownAnnots v) (UpAnnots b v m) Annotation (QDiaLeaf b v m) + _Wrapped' = iso (\(QD d) -> d) QD +instance Rewrapped (QDiagram b v m) (QDiagram b' v' m') + type instance V (QDiagram b v m) = v -- | The default sort of diagram is one where querying at a point @@ -266,7 +292,7 @@ => QDiagram b v m -> [(Prim b v, (Split (Transformation v), Style v))] prims = concatMap processLeaf . D.flatten - . view unwrapped + . view _Wrapped' where processLeaf (PrimLeaf p, (trSty,_)) = [(p, untangle . option mempty id $ trSty)] processLeaf (DelayedLeaf k, d) = prims (k d) @@ -280,14 +306,14 @@ 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) +envelope = lens (unDelete . getU' . view _Wrapped') (flip setEnvelope) -- | Replace the envelope of a diagram. 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 unwrapped ( D.applyUpre (inj . toDeletable $ e) + over _Wrapped' ( D.applyUpre (inj . toDeletable $ e) . D.applyUpre (inj (deleteL :: Deletable (Envelope v))) . D.applyUpost (inj (deleteR :: Deletable (Envelope v))) ) @@ -295,13 +321,13 @@ -- | Get the trace of a diagram. 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) +trace = lens (unDelete . getU' . view _Wrapped') (flip setTrace) -- | Replace the trace of a diagram. 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 unwrapped ( D.applyUpre (inj . toDeletable $ t) +setTrace t = over _Wrapped' ( D.applyUpre (inj . toDeletable $ t) . D.applyUpre (inj (deleteL :: Deletable (Trace v))) . D.applyUpost (inj (deleteR :: Deletable (Trace v))) ) @@ -310,22 +336,26 @@ -- subdiagrams) of a diagram. 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 +subMap = lens (unDelete . getU' . view _Wrapped') (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) + setMap m = over _Wrapped' ( D.applyUpre . inj . toDeletable $ m) -- | Get a list of names of subdiagrams and their locations. 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) +names = (map . second . map) location . M.assocs . view (subMap . _Wrapped') -- | Attach an atomic name to a certain subdiagram, computed from the --- given diagram. +-- given diagram /with the mapping from name to subdiagram +-- included/. The upshot of this knot-tying is that if @d' = d # +-- named x@, then @lookupName x d' == Just d'@ (instead of @Just +-- d@). 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 unwrapped (D.applyUpre . inj . toDeletable $ fromNames [(n,s d)]) d +nameSub s n d = d' + where d' = over _Wrapped' (D.applyUpre . inj . toDeletable $ fromNames [(n,s d')]) d -- | Lookup the most recent diagram associated with (some -- qualification of) the given name. @@ -374,14 +404,14 @@ , OrderedField (Scalar v), Semigroup m ) => QDiagram b v m -> QDiagram b v m -localize = over unwrapped ( D.applyUpre (inj (deleteL :: Deletable (SubMap b v m))) +localize = over _Wrapped' ( 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' . view unwrapped +query = getU' . view _Wrapped' -- | Sample a diagram's query function at a given point. sample :: Monoid m => QDiagram b v m -> Point v -> m @@ -460,7 +490,7 @@ ---- Functor instance Functor (QDiagram b v) where - fmap f = over unwrapped + fmap f = over (_Wrapping QD) ( (D.mapU . second . second) ( (first . fmap . fmap . fmap) f . (second . first . fmap . fmap) f @@ -489,7 +519,7 @@ instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => HasStyle (QDiagram b v m) where - applyStyle = over unwrapped . D.applyD . inj + applyStyle = over _Wrapped' . D.applyD . inj . (inR :: Style v -> Split (Transformation v) :+: Style v) -- | By default, diagram attributes are not affected by @@ -511,7 +541,7 @@ freeze :: forall v b m. (HasLinearMap v, InnerSpace v , OrderedField (Scalar v), Semigroup m) => QDiagram b v m -> QDiagram b v m -freeze = over unwrapped . D.applyD . inj +freeze = over _Wrapped' . D.applyD . inj . (inL :: Split (Transformation v) -> Split (Transformation v) :+: Style v) $ split @@ -549,7 +579,7 @@ -- components appropriately. instance (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Semigroup m) => Transformable (QDiagram b v m) where - transform = over unwrapped . D.applyD . transfToAnnot + transform = over _Wrapped' . D.applyD . transfToAnnot ---- Qualifiable @@ -557,7 +587,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 unwrapped . D.applyD . inj . toName + (|>) = over _Wrapped' . D.applyD . inj . toName ------------------------------------------------------------ @@ -626,7 +656,7 @@ , Semigroup m ) => Subdiagram b v m -> QDiagram b v m -getSub (Subdiagram d a) = over unwrapped (D.applyD a) d +getSub (Subdiagram d a) = over _Wrapped' (D.applyD a) d -- | Extract the \"raw\" content of a subdiagram, by throwing away the -- context. @@ -642,12 +672,12 @@ newtype SubMap b v m = SubMap (M.Map Name [Subdiagram b v m]) -- See Note [SubMap Set vs list] -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) +instance Wrapped (SubMap b v m) where + type Unwrapped (SubMap b v m) = M.Map Name [Subdiagram b v m] + _Wrapped' = iso (\(SubMap m) -> m) SubMap +instance Rewrapped (SubMap b v m) (SubMap b' v' m') + -- ~~~~ [SubMap Set vs list] -- In some sense it would be nicer to use -- Sets instead of a list, but then we would have to put Ord @@ -656,7 +686,7 @@ type instance V (SubMap b v m) = v instance Functor (SubMap b v) where - fmap = over unwrapped . fmap . map . fmap + fmap = over _Wrapped . fmap . map . fmap instance Semigroup (SubMap b v m) where SubMap s1 <> SubMap s2 = SubMap $ M.unionWith (++) s1 s2 @@ -672,11 +702,11 @@ instance (OrderedField (Scalar v), InnerSpace v, HasLinearMap v) => HasOrigin (SubMap b v m) where - moveOriginTo = over unwrapped . moveOriginTo + moveOriginTo = over _Wrapped' . moveOriginTo instance (InnerSpace v, Floating (Scalar v), HasLinearMap v) => Transformable (SubMap b v m) where - transform = over unwrapped . transform + transform = over _Wrapped' . transform -- | 'SubMap's are qualifiable: if @ns@ is a 'SubMap', then @a |> -- ns@ is the same 'SubMap' except with every name qualified by @@ -691,7 +721,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 unwrapped $ M.insertWith (++) (toName n) [mkSubdiagram b] +rememberAs n b = over _Wrapped' $ 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 @@ -742,7 +772,7 @@ -- | A value of type @Prim b v@ is an opaque (existentially quantified) -- primitive which backend @b@ knows how to render in vector space @v@. data Prim b v where - Prim :: (IsPrim p, Renderable p b) => p -> Prim b (V p) + Prim :: (IsPrim p, Typeable p, Renderable p b) => p -> Prim b (V p) type instance V (Prim b v) = v @@ -761,6 +791,7 @@ -- | The null primitive. data NullPrim v = NullPrim + deriving Typeable type instance (V (NullPrim v)) = v @@ -774,7 +805,7 @@ -- | The null primitive, which every backend can render by doing -- nothing. -nullPrim :: (HasLinearMap v, Monoid (Render b v)) => Prim b v +nullPrim :: (HasLinearMap v, Typeable v, Monoid (Render b v)) => Prim b v nullPrim = Prim NullPrim ------------------------------------------------------------ @@ -814,7 +845,7 @@ -- in the context of an arbitrary -- transformation; such backends can instead use -- the 'avgScale' function from - -- "Diagrams.TwoD.Transform" (from the + -- @Diagrams.TwoD.Transform@ (from the -- @diagrams-lib@ package). | RAnnot a | RPrim (Transformation v) (Prim b v) @@ -864,7 +895,7 @@ -- support stroking in the context of an -- arbitrary transformation; such backends can -- instead use the 'avgScale' function from - -- "Diagrams.TwoD.Transform" (from the + -- @Diagrams.TwoD.Transform@ (from the -- @diagrams-lib@ package). -> Render b v -- ^ Rendering operation to run -> Render b v -- ^ Rendering operation using the style locally @@ -922,18 +953,19 @@ -- For example, here is the error we get if we try to compute the -- width of an image (this example requires @diagrams-lib@): -- --- > ghci> width (image "foo.png" 200 200) --- > --- > :8:8: --- > No instance for (Renderable Diagrams.TwoD.Image.Image b0) --- > arising from a use of `image' --- > Possible fix: --- > add an instance declaration for --- > (Renderable Diagrams.TwoD.Image.Image b0) --- > In the first argument of `width', namely --- > `(image "foo.png" 200 200)' --- > In the expression: width (image "foo.png" 200 200) --- > In an equation for `it': it = width (image "foo.png" 200 200) +-- @ +-- ghci> width (image \"foo.png\" 200 200) +-- \:8:8: +-- No instance for (Renderable Diagrams.TwoD.Image.Image b0) +-- arising from a use of `image' +-- Possible fix: +-- add an instance declaration for +-- (Renderable Diagrams.TwoD.Image.Image b0) +-- In the first argument of `width', namely +-- `(image \"foo.png\" 200 200)' +-- In the expression: width (image \"foo.png\" 200 200) +-- In an equation for `it': it = width (image \"foo.png\" 200 200) +-- @ -- -- GHC complains that there is no instance for @Renderable Image -- b0@; what is really going on is that it does not have enough @@ -946,20 +978,23 @@ -- The solution is to annotate the call to 'image' with the type -- @'D' 'R2'@, like so: -- --- > ghci> width (image "foo.png" 200 200 :: D R2) --- > 200.00000000000006 +-- @ +-- ghci> width (image \"foo.png\" 200 200 :: D R2) +-- 200.00000000000006 +-- @ -- -- (It turns out the width wasn't 200 after all...) -- -- As another example, here is the error we get if we try to compute -- the width of a radius-1 circle: -- --- > ghci> width (circle 1) --- > --- > :4:1: --- > Couldn't match type `V a0' with `R2' --- > In the expression: width (circle 1) --- > In an equation for `it': it = width (circle 1) +-- @ +-- ghci> width (circle 1) +-- \:4:1: +-- Couldn't match type `V a0' with `R2' +-- In the expression: width (circle 1) +-- In an equation for `it': it = width (circle 1) +-- @ -- -- There's even more ambiguity here. Whereas 'image' always returns -- a 'Diagram', the 'circle' function can produce any 'PathLike' @@ -967,8 +1002,10 @@ -- so GHC has no idea what type to pick to go in the middle. -- However, the solution is the same: -- --- > ghci> width (circle 1 :: D R2) --- > 1.9999999999999998 +-- @ +-- ghci> width (circle 1 :: D R2) +-- 1.9999999999999998 +-- @ type D v = Diagram NullBackend v