{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Combinators -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Higher-level tools for combining diagrams. -- ----------------------------------------------------------------------------- module Diagrams.Combinators ( -- * Unary operations withEnvelope, withTrace , phantom, strut , pad, frame , extrudeEnvelope, intrudeEnvelope -- * Binary operations , atop , beneath , beside , atDirection -- * n-ary operations , appends , position, atPoints , cat, cat' , CatOpts(_catMethod, _sep), catMethod, sep , CatMethod(..) , composeAligned ) where import Control.Lens hiding (beside, ( # )) import Data.Default.Class import Data.Maybe (fromJust) import Data.Monoid.Deletable (toDeletable) import Data.Monoid.MList (inj) import Data.Proxy import Data.Semigroup import qualified Data.Tree.DUAL as D import Diagrams.Core import Diagrams.Core.Types (QDiagram (QD)) import Diagrams.Direction import Diagrams.Names (named) import Diagrams.Segment (straight) import Diagrams.Util import Linear.Affine import Linear.Metric import Linear.Vector ------------------------------------------------------------ -- Working with envelopes ------------------------------------------------------------ -- | Use the envelope from some object as the envelope for a -- diagram, in place of the diagram's default envelope. -- -- <<diagrams/src_Diagrams_Combinators_withEnvelopeEx.svg#diagram=withEnvelopeEx&width=300>> -- -- > sqNewEnv = -- > circle 1 # fc green -- > ||| -- > ( c # dashingG [0.1,0.1] 0 # lc white -- > <> square 2 # withEnvelope (c :: D V2 Double) # fc blue -- > ) -- > c = circle 0.8 -- > withEnvelopeEx = sqNewEnv # centerXY # pad 1.5 withEnvelope :: (InSpace v n a, Monoid' m, Enveloped a) => a -> QDiagram b v n m -> QDiagram b v n m withEnvelope = setEnvelope . getEnvelope -- | Use the trace from some object as the trace for a diagram, in -- place of the diagram's default trace. withTrace :: (InSpace v n a, Metric v, OrderedField n, Monoid' m, Traced a) => a -> QDiagram b v n m -> QDiagram b v n m withTrace = setTrace . getTrace -- | @phantom x@ produces a \"phantom\" diagram, which has the same -- envelope and trace as @x@ but produces no output. phantom :: (InSpace v n a, Monoid' m, Enveloped a, Traced a) => a -> QDiagram b v n m phantom a = QD $ D.leafU ((inj . toDeletable . getEnvelope $ a) <> (inj . toDeletable . getTrace $ a)) -- | @pad s@ \"pads\" a diagram, expanding its envelope by a factor of -- @s@ (factors between 0 and 1 can be used to shrink the envelope). -- Note that the envelope will expand with respect to the local -- origin, so if the origin is not centered the padding may appear -- \"uneven\". If this is not desired, the origin can be centered -- (using, e.g., 'centerXY' for 2D diagrams) before applying @pad@. pad :: (Metric v, OrderedField n, Monoid' m) => n -> QDiagram b v n m -> QDiagram b v n m pad s d = withEnvelope (d # scale s) d -- | @frame s@ increases the envelope of a diagram by and absolute amount @s@, -- s is in the local units of the diagram. This function is similar to @pad@, -- only it takes an absolute quantity and pre-centering should not be -- necessary. frame :: (Metric v, OrderedField n, Monoid' m) => n -> QDiagram b v n m -> QDiagram b v n m frame s = over envelope (onEnvelope $ \f x -> f x + s) -- | @strut v@ is a diagram which produces no output, but with respect -- to alignment and envelope acts like a 1-dimensional segment -- oriented along the vector @v@, with local origin at its -- center. (Note, however, that it has an empty trace; for 2D struts -- with a nonempty trace see 'strutR2' from -- "Diagrams.TwoD.Combinators".) Useful for manually creating -- separation between two diagrams. -- -- <<diagrams/src_Diagrams_Combinators_strutEx.svg#diagram=strutEx&width=300>> -- -- > strutEx = (circle 1 ||| strut unitX ||| circle 1) # centerXY # pad 1.1 strut :: (Metric v, OrderedField n) => v n -> QDiagram b v n m strut v = QD $ D.leafU (inj . toDeletable $ env) where env = translate ((-0.5) *^ v) . getEnvelope $ straight v -- note we can't use 'phantom' here because it tries to construct a -- trace as well, and segments do not have a trace in general (only -- in 2D; see Diagrams.TwoD.Segment). This is a good reason to have -- a special 'strut' combinator (before the introduction of traces -- it was mostly just for convenience). -- -- also note that we can't remove the call to getEnvelope, since -- translating a segment has no effect. -- | @extrudeEnvelope v d@ asymmetrically \"extrudes\" the envelope of -- a diagram in the given direction. All parts of the envelope -- within 90 degrees of this direction are modified, offset outwards -- by the magnitude of the vector. -- -- This works by offsetting the envelope distance proportionally to -- the cosine of the difference in angle, and leaving it unchanged -- when this factor is negative. extrudeEnvelope :: (Metric v, OrderedField n, Monoid' m) => v n -> QDiagram b v n m -> QDiagram b v n m extrudeEnvelope = deformEnvelope 0.5 -- | @intrudeEnvelope v d@ asymmetrically \"intrudes\" the envelope of -- a diagram away from the given direction. All parts of the envelope -- within 90 degrees of this direction are modified, offset inwards -- by the magnitude of the vector. -- -- Note that this could create strange inverted envelopes, where -- @ diameter v d < 0 @. intrudeEnvelope :: (Metric v, OrderedField n, Monoid' m) => v n -> QDiagram b v n m -> QDiagram b v n m intrudeEnvelope = deformEnvelope (-0.5) -- Utility for extrudeEnvelope / intrudeEnvelope deformEnvelope :: (Metric v, OrderedField n, Monoid' m) => n -> v n -> QDiagram b v n m -> QDiagram b v n m deformEnvelope s v = over (envelope . _Wrapping Envelope) deformE where deformE = Option . fmap deformE' . getOption deformE' env v' | dp > 0 = Max $ getMax (env v') + (dp * s) / norm v' | otherwise = env v' where dp = v' `dot` v ------------------------------------------------------------ -- Combining two objects ------------------------------------------------------------ -- | @beneath@ is just a convenient synonym for @'flip' 'atop'@; that is, -- @d1 \`beneath\` d2@ is the diagram with @d2@ superimposed on top of -- @d1@. beneath :: (Metric v, OrderedField n, Monoid' m) => QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m beneath = flip atop infixl 6 `beneath` -- | Place two monoidal objects (/i.e./ diagrams, paths, -- animations...) next to each other along the given vector. In -- particular, place the second object so that the vector points -- from the local origin of the first object to the local origin of -- the second object, at a distance so that their envelopes are just -- tangent. The local origin of the new, combined object is the -- local origin of the first object (unless the first object is the -- identity element, in which case the second object is returned -- unchanged). -- -- <<diagrams/src_Diagrams_Combinators_besideEx.svg#diagram=besideEx&height=200>> -- -- > besideEx = beside (r2 (20,30)) -- > (circle 1 # fc orange) -- > (circle 1.5 # fc purple) -- > # showOrigin -- > # centerXY # pad 1.1 -- -- Note that @beside v@ is associative, so objects under @beside v@ -- form a semigroup for any given vector @v@. In fact, they also -- form a monoid: 'mempty' is clearly a right identity (@beside v d1 -- mempty === d1@), and there should also be a special case to make -- it a left identity, as described above. -- -- In older versions of diagrams, @beside@ put the local origin of -- the result at the point of tangency between the two inputs. That -- semantics can easily be recovered by performing an alignment on -- the first input before combining. That is, if @beside'@ denotes -- the old semantics, -- -- > beside' v x1 x2 = beside v (x1 # align v) x2 -- -- To get something like @beside v x1 x2@ whose local origin is -- identified with that of @x2@ instead of @x1@, use @beside -- (negateV v) x2 x1@. beside :: (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a beside v d1 d2 = d1 <> juxtapose v d1 d2 -- | Place two diagrams (or other juxtaposable objects) adjacent to -- one another, with the second diagram placed in the direction 'd' -- from the first. The local origin of the resulting combined -- diagram is the same as the local origin of the first. See the -- documentation of 'beside' for more information. atDirection :: (InSpace v n a, Metric v, Floating n, Juxtaposable a, Semigroup a) => Direction v n -> a -> a -> a atDirection = beside . fromDirection ------------------------------------------------------------ -- Combining multiple objects ------------------------------------------------------------ -- | @appends x ys@ appends each of the objects in @ys@ to the object -- @x@ in the corresponding direction. Note that each object in -- @ys@ is positioned beside @x@ /without/ reference to the other -- objects in @ys@, so this is not the same as iterating 'beside'. -- -- <<diagrams/src_Diagrams_Combinators_appendsEx.svg#diagram=appendsEx&width=200>> -- -- > appendsEx = appends c (zip (iterateN 6 (rotateBy (1/6)) unitX) (repeat c)) -- > # centerXY # pad 1.1 -- > where c = circle 1 appends :: (Juxtaposable a, Monoid' a) => a -> [(Vn a,a)] -> a appends d1 apps = d1 <> mconcat (map (\(v,d) -> juxtapose v d1 d) apps) -- | Position things absolutely: combine a list of objects -- (e.g. diagrams or paths) by assigning them absolute positions in -- the vector space of the combined object. -- -- <<diagrams/src_Diagrams_Combinators_positionEx.svg#diagram=positionEx&height=300>> -- -- > positionEx = position (zip (map mkPoint [-3, -2.8 .. 3]) (repeat spot)) -- > where spot = circle 0.2 # fc black -- > mkPoint :: Double -> P2 Double -- > mkPoint x = p2 (x,x*x) position :: (InSpace v n a, HasOrigin a, Monoid' a) => [(Point v n, a)] -> a position = mconcat . map (uncurry moveTo) -- | Curried version of @position@, takes a list of points and a list of -- objects. atPoints :: (InSpace v n a, HasOrigin a, Monoid' a) => [Point v n] -> [a] -> a atPoints ps as = position $ zip ps as -- | Methods for concatenating diagrams. data CatMethod = Cat -- ^ Normal catenation: simply put diagrams -- next to one another (possibly with a -- certain distance in between each). The -- distance between successive diagram -- /envelopes/ will be consistent; the -- distance between /origins/ may vary if -- the diagrams are of different sizes. | Distrib -- ^ Distribution: place the local origins of -- diagrams at regular intervals. With -- this method, the distance between -- successive /origins/ will be consistent -- but the distance between envelopes may -- not be. Indeed, depending on the amount -- of separation, diagrams may overlap. -- | Options for 'cat''. data CatOpts n = CatOpts { _catMethod :: CatMethod , _sep :: n , catOptsvProxy :: Proxy n } -- The reason the proxy field is necessary is that without it, -- altering the sep field could theoretically change the type of a -- CatOpts record. This causes problems when using record update, as -- in @with { _sep = 10 }@, because knowing the type of the whole -- expression does not tell us anything about the type of @with@, and -- therefore the @Num (Scalar v)@ constraint cannot be satisfied. -- Adding the Proxy field constrains the type of @with@ in @with {_sep -- = 10}@ to be the same as the type of the whole expression. Note -- this is not a problem when using the 'sep' lens, as its type is -- more restricted. makeLensesWith (lensRules & generateSignatures .~ False) ''CatOpts -- | Which 'CatMethod' should be used: -- normal catenation (default), or distribution? catMethod :: Lens' (CatOpts n) CatMethod -- | How much separation should be used between successive diagrams -- (default: 0)? When @catMethod = Cat@, this is the distance between -- /envelopes/; when @catMethod = Distrib@, this is the distance -- between /origins/. sep :: Lens' (CatOpts n) n instance Num n => Default (CatOpts n) where def = CatOpts { _catMethod = Cat , _sep = 0 , catOptsvProxy = Proxy } -- | @cat v@ positions a list of objects so that their local origins -- lie along a line in the direction of @v@. Successive objects -- will have their envelopes just touching. The local origin -- of the result will be the same as the local origin of the first -- object. -- -- See also 'cat'', which takes an extra options record allowing -- certain aspects of the operation to be tweaked. cat :: (InSpace v n a, Metric v, Floating n, Juxtaposable a, Monoid' a, HasOrigin a) => v n -> [a] -> a cat v = cat' v def -- | Like 'cat', but taking an extra 'CatOpts' arguments allowing the -- user to specify -- -- * The spacing method: catenation (uniform spacing between -- envelopes) or distribution (uniform spacing between local -- origins). The default is catenation. -- -- * The amount of separation between successive diagram -- envelopes/origins (depending on the spacing method). The -- default is 0. -- -- 'CatOpts' is an instance of 'Default', so 'with' may be used for -- the second argument, as in @cat' (1,2) (with & sep .~ 2)@. -- -- Note that @cat' v (with & catMethod .~ Distrib) === mconcat@ -- (distributing with a separation of 0 is the same as -- superimposing). cat' :: (InSpace v n a, Metric v, Floating n, Juxtaposable a, Monoid' a, HasOrigin a) => v n -> CatOpts n -> [a] -> a cat' v (CatOpts { _catMethod = Cat, _sep = s }) = foldB comb mempty where comb d1 d2 = d1 <> (juxtapose v d1 d2 # moveOriginBy vs) vs = s *^ signorm (negated v) cat' v (CatOpts { _catMethod = Distrib, _sep = s }) = position . zip (iterate (.+^ (s *^ signorm v)) origin) -- | Compose a list of diagrams using the given composition function, -- first aligning them all according to the given alignment, /but/ -- retain the local origin of the first diagram, as it would be if -- the composition function were applied directly. That is, -- @composeAligned algn comp@ is equivalent to @translate v . comp -- . map algn@ for some appropriate translation vector @v@. -- -- Unfortunately, this only works for diagrams (and not, say, paths) -- because there is no most general type for alignment functions, -- and no generic way to find out what an alignment function does to -- the origin of things. (However, it should be possible to make a -- version of this function that works /specifically/ on paths, if -- such a thing were deemed useful.) -- -- <<diagrams/src_Diagrams_Combinators_alignedEx1.svg#diagram=alignedEx1&width=400>> -- -- > alignedEx1 = (hsep 2 # composeAligned alignT) (map circle [1,3,5,2]) -- > # showOrigin -- > # frame 0.5 -- -- <<diagrams/src_Diagrams_Combinators_alignedEx2.svg#diagram=alignedEx2&width=400>> -- -- > alignedEx2 = (mconcat # composeAligned alignTL) [circle 1, square 1, triangle 1, pentagon 1] -- > # showOrigin -- > # frame 0.1 composeAligned :: (Monoid' m, Floating n, Ord n, Metric v) => (QDiagram b v n m -> QDiagram b v n m) -- ^ Alignment function -> ([QDiagram b v n m] -> QDiagram b v n m) -- ^ Composition function -> ([QDiagram b v n m] -> QDiagram b v n m) composeAligned _ combine [] = combine [] composeAligned algn comb (d:ds) = (comb $ map algn (d:ds)) # moveOriginTo l where mss = ( (() .>> d) -- qualify first to avoid stomping on an existing () name # named () -- Mark the origin # algn -- Apply the alignment function ) -- then find out what happened to the origin ^. subMap . _Wrapped . Control.Lens.at (toName ()) l = location . head . fromJust $ mss -- the fromJust is Justified since we put the () name in