append-align: Support optional gap argument.

1 files changed, 61 insertions, 49 deletions

diff --git a/pict.scm b/pict.scm
index 3a84476..fdf9bbd 100644
--- a/pict.scm
+++ b/pict.scm
@@ -681,55 +681,67 @@ of the SVG of PICT or #F."
   "Append PICTS and align them vertically to the top, center, bottom,
 or spread by an offset according to the symbol YALIGN and horizontally
 to the left, center, right, or spread them with an offset according to
-the symbol XALIGN."
-  (let* ((heights    (map pict-height picts))
-         (widths     (map pict-width picts))
-         (new-height (apply (if (eq? yalign 'offset) + max) heights))
-         (new-width  (apply (if (eq? xalign 'offset) + max) widths))
-         (x-offsets  (if (eq? xalign 'offset)
-                         (scan widths)
-                         (list-tabulate (length picts) (const 0))))
-         (y-offsets  (if (eq? yalign 'offset)
-                         (scan heights)
-                         (list-tabulate (length picts) (const 0))))
-         (aligner    (match-lambda
-                       ((xoffset yoffset pict)
-                        ((compose
-                          (attribute-modifier
-                           'x (match xalign
-                                ('left   identity)
-                                ('center (lambda _
-                                           (exact->inexact
-                                            (- (/ new-width 2)
-                                               (/ (pict-width pict) 2)))))
-                                ('right  (lambda _
-                                           (exact->inexact
-                                            (- new-width
-                                               (pict-width pict)))))
-                                ('offset (const xoffset))))
-                          (attribute-modifier
-                           'y (match yalign
-                                ('top    identity)
-                                ('center (lambda _
-                                           (exact->inexact
-                                            (- (/ new-height 2)
-                                               (/ (pict-height pict) 2)))))
-                                ('bottom (lambda _
-                                           (exact->inexact
-                                            (- new-height
-                                               (pict-height pict)))))
-                                ('offset (const yoffset)))))
-                         (pict-sxml pict))))))
-    (make-pict
-     `(svg (@ (height ,new-height)
-              (width  ,new-width)
-              (class ,(string-append "aligned-"
-                                     (symbol->string xalign)
-                                     "-"
-                                     (symbol->string yalign)))
-              (x 0)
-              (y 0))
-           ,@(map aligner (zip x-offsets y-offsets picts))))))
+the symbol XALIGN.  When the first element of PICTS is a number, use
+it as a gap between PICTS."
+  (let-values (((gap picts) (match picts
+                              (((? number? gap) . picts)
+                               (values gap picts))
+                              (_ (values 0 picts)))))
+    (let* ((heights    (map pict-height picts))
+           (widths     (map pict-width picts))
+           (gaps       (* (- (length picts) 1) gap))
+           (new-height (if (eq? yalign 'offset)
+                           (+ (apply + heights) gaps)
+                           (apply max heights)))
+           (new-width  (if (eq? xalign 'offset)
+                           (+ (apply + widths) gaps)
+                           (apply max widths)))
+           (x-offsets  (if (eq? xalign 'offset)
+                           (map + (scan widths)
+                                  (scan (list-tabulate (length picts) (const gap))))
+                           (list-tabulate (length picts) (const gap))))
+           (y-offsets  (if (eq? yalign 'offset)
+                           (map + (scan heights)
+                                  (scan (list-tabulate (length picts) (const gap))))
+                           (list-tabulate (length picts) (const gap))))
+           (aligner    (match-lambda
+                         ((xoffset yoffset pict)
+                          ((compose
+                            (attribute-modifier
+                             'x (match xalign
+                                  ('left   identity)
+                                  ('center (lambda _
+                                             (exact->inexact
+                                              (- (/ new-width 2)
+                                                 (/ (pict-width pict) 2)))))
+                                  ('right  (lambda _
+                                             (exact->inexact
+                                              (- new-width
+                                                 (pict-width pict)))))
+                                  ('offset (const xoffset))))
+                            (attribute-modifier
+                             'y (match yalign
+                                  ('top    identity)
+                                  ('center (lambda _
+                                             (exact->inexact
+                                              (- (/ new-height 2)
+                                                 (/ (pict-height pict) 2)))))
+                                  ('bottom (lambda _
+                                             (exact->inexact
+                                              (- new-height
+                                                 (pict-height pict)))))
+                                  ('offset (const yoffset)))))
+                           (pict-sxml pict))))))
+      (make-pict
+       `(svg (@ (height ,new-height)
+                (width  ,new-width)
+                (class ,(string-append "aligned-"
+                                       (symbol->string xalign)
+                                       "-"
+                                       (symbol->string yalign)))
+                (x 0)
+                (y 0))
+             ,@(map aligner (zip x-offsets y-offsets picts)))))))
 
 (define (ht-append . picts)
   "Line up the given PICTS horizontally on the top."