Merge pull request #256 from diagrams/compose-aligned

Add a `composeAligned` combinator

for doing composition under an alignment but leaving the local origin unaffected.

src/Diagrams/Combinators.hs

@@ -35,11 +35,13 @@ module Diagrams.Combinators
        , 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
@@ -49,6 +51,7 @@ 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
 
@@ -351,3 +354,43 @@ cat' v (CatOpts { _catMethod = Cat, _sep = s }) = foldB comb mempty
 
 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.)
+--
+--   <<#diagram=alignedEx1&width=400>>
+--
+--   > alignedEx1 = (hsep 2 # composeAligned alignT) (map circle [1,3,5,2])
+--   >            # showOrigin
+--
+--   <<#diagram=alignedEx2&width=400>>
+--
+--   > alignedEx2 = (mconcat # composeAligned alignTL) [circle 1, square 1, triangle 1, pentagon 1]
+--   >            # showOrigin
+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