diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index 27de7ecb..1654282b 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -37,16 +37,18 @@ module Diagrams.Combinators ) where +import Data.AdditiveGroup hiding (Sum, getSum) import Control.Lens ( (&), (%~), (.~), Lens', makeLensesWith , lensRules, lensField, generateSignatures, unwrapping) -import Data.AdditiveGroup import Data.AffineSpace ((.+^)) import Data.Default.Class import Data.Proxy import Data.Semigroup -import Data.VectorSpace +import Data.VectorSpace hiding (Sum, getSum) +import Data.Monoid.Cut import Diagrams.Core +import Diagrams.Core.Envelope import Diagrams.Located import Diagrams.Path import Diagrams.Segment (straight) @@ -342,7 +344,7 @@ instance Num (Scalar v) => Default (CatOpts v) where -- -- See also 'cat'', which takes an extra options record allowing -- certain aspects of the operation to be tweaked. -cat :: ( Juxtaposable a, Monoid' a, HasOrigin a +cat :: ( HasEmpty a, Juxtaposable a, Monoid' a, HasOrigin a , InnerSpace (V a), OrderedField (Scalar (V a)) ) => V a -> [a] -> a @@ -365,13 +367,23 @@ cat v = cat' v def -- Note that @cat' v with {catMethod = Distrib} === mconcat@ -- (distributing with a separation of 0 is the same as -- superimposing). -cat' :: ( Juxtaposable a, Monoid' a, HasOrigin a +cat' :: ( HasEmpty a, Juxtaposable a, Monoid' a, HasOrigin a , InnerSpace (V a), OrderedField (Scalar (V a)) ) => V a -> CatOpts (V a) -> [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 *^ normalized (negateV v) +cat' v (CatOpts { _catMethod = Cat, _sep = s }) + = snd . foldB comb mempty . map setSpace + where setSpace a = if isEmpty a + then (Uncut (Sum s), a) + else (Sum 0 :||: Sum s, a) + unit = normalized (negateV v) + comb (s1,d1) (s2,d2) = (s1 <> s2, d1 <> juxtapose v d1 d2 # moveOriginBy vs) where + vs = spacing *^ unit + spacing = rhs s1 ^+^ lhs s2 + rhs (Uncut a) = getSum a + rhs (_ :||: a) = getSum a + lhs (Uncut _) = 0 + lhs (a :||: _) = getSum a cat' v (CatOpts { _catMethod = Distrib, _sep = s }) = position . zip (iterate (.+^ (s *^ normalized v)) origin) diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index fa7ad089..8ce2995a 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -109,14 +109,14 @@ atAngle th = beside (fromDirection th) -- "Diagrams.TwoD.Align" before applying 'hcat'. -- -- * For non-axis-aligned layout, see 'cat'. -hcat :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) +hcat :: (HasEmpty a, Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => [a] -> a hcat = hcat' def -- | A variant of 'hcat' taking an extra 'CatOpts' record to control -- the spacing. See the 'cat'' documentation for a description of -- the possibilities. -hcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) +hcat' :: (HasEmpty a, Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => CatOpts R2 -> [a] -> a hcat' = cat' unitX @@ -131,14 +131,14 @@ hcat' = cat' unitX -- "Diagrams.TwoD.Align" before applying 'vcat'. -- -- * For non-axis-aligned layout, see 'cat'. -vcat :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) +vcat :: (HasEmpty a, Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => [a] -> a vcat = vcat' def -- | A variant of 'vcat' taking an extra 'CatOpts' record to control -- the spacing. See the 'cat'' documentation for a description of the -- possibilities. -vcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) +vcat' :: (HasEmpty a, Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => CatOpts R2 -> [a] -> a vcat' = cat' (negateV unitY)