Merge branch 'jneeman' of git+ssh://jneem@git.sv.gnu.org/srv/git/lilypond into jneeman

[lilypond.git] / scm / define-markup-commands.scm

diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm
index 4d87479283bfff0509b02dd0a7b5d819de6b7387..5d96ecb179be690a0930a48c51ec4dfb72cddc8e 100644 (file)
--- a/scm/define-markup-commands.scm
+++ b/scm/define-markup-commands.scm
@@ -127,17 +127,7 @@ circle of diameter 0 (ie sharp corners)."
 
 (define-markup-command (whiteout layout props arg) (markup?)
   "Provide a white underground for @var{arg}"
-  (let* ((stil (interpret-markup layout props arg))
-        (white
-         (interpret-markup layout props
-                           (make-with-color-markup
-                            white
-                            (make-filled-box-markup
-                             (ly:stencil-extent stil X)
-                             (ly:stencil-extent stil Y)
-                             0.0)))))
-
-    (ly:stencil-add white stil)))
+  (stencil-whiteout (interpret-markup layout props arg)))
 
 (define-markup-command (pad-markup layout props padding arg) (number? markup?)
   "Add space around a markup object."
@@ -416,6 +406,28 @@ determines the space between each markup in @var{args}."
      space
      (remove ly:stencil-empty? stencils))))
 
+(define-markup-command (concat layout props args) (markup-list?)
+  "Concatenate @var{args} in a horizontal line, without spaces inbetween.
+Strings and simple markups are concatenated on the input level, allowing
+ligatures.  For example, @code{\\concat @{ \"f\" \\simple #\"i\" @}} is
+equivalent to @code{\"fi\"}."
+
+  (define (concat-string-args arg-list)
+    (fold-right (lambda (arg result-list)
+                  (let ((result (if (pair? result-list)
+                                    (car result-list)
+                                  '())))
+                    (if (and (pair? arg) (eqv? (car arg) simple-markup))
+                      (set! arg (cadr arg)))
+                    (if (and (string? result) (string? arg))
+                        (cons (string-append arg result) (cdr result-list))
+                      (cons arg result-list))))
+                '()
+                arg-list))
+
+  (interpret-markup layout
+                    (prepend-alist-chain 'word-space 0 props)
+                    (make-line-markup (concat-string-args args))))
 
 (define (wordwrap-stencils stencils
                           justify base-space line-width text-dir)
@@ -577,7 +589,7 @@ line-width, where X is the number of staff spaces."
       (ly:make-stencil '()  '(1 . -1) '(1 . -1)))))
 
 (define-markup-command (justify-field layout props symbol) (symbol?)
--   (let* ((m (chain-assoc-get symbol props)))
+   (let* ((m (chain-assoc-get symbol props)))
      (if (string? m)
       (interpret-markup layout props
        (list justify-string-markup m))
@@ -896,7 +908,7 @@ some punctuation. It doesn't have any letters.  "
   "Set font size to -3."
   (interpret-markup layout (prepend-alist-chain 'font-size -3 props) arg))
 
-(define-markup-command (caps layout props arg) (markup?)
+(define-markup-command (fontCaps layout props arg) (markup?)
   "Set @code{font-shape} to @code{caps}."
   (interpret-markup layout (prepend-alist-chain 'font-shape 'caps props) arg))
 
@@ -966,6 +978,9 @@ some punctuation. It doesn't have any letters.  "
                                                 #f
                                                 #f)))
 
+(define-markup-command (caps layout props arg) (markup?)
+  (interpret-markup layout props (make-smallCaps-markup arg)))
+
 (define-markup-command (dynamic layout props arg) (markup?)
   "Use the dynamic font.  This font only contains @b{s}, @b{f}, @b{m},
 @b{z}, @b{p}, and @b{r}.  When producing phrases, like ``pi@`{u} @b{f}'', the
@@ -1187,6 +1202,7 @@ figured bass notation"
 (define-markup-command (note-by-number layout props log dot-count dir) (number? number? number?)
   "Construct a note symbol, with stem.  By using fractional values for
 @var{dir}, you can obtain longer or shorter stems."
+
   (define (get-glyph-name-candidates dir log style)
     (map (lambda (dir-name)
      (format "noteheads.~a~a~a" dir-name (min log 2)
@@ -1208,22 +1224,22 @@ figured bass notation"
         (size-factor (magstep (chain-assoc-get 'font-size props 0)))
         (style (chain-assoc-get 'style props '()))
          (stem-length (*  size-factor (max 3 (- log 1))))
-         (head-glyph-name (get-glyph-name font (get-glyph-name-candidates dir log style)))
+         (head-glyph-name (get-glyph-name font (get-glyph-name-candidates (sign dir) log style)))
          (head-glyph (ly:font-get-glyph font head-glyph-name))
         (attach-indices (ly:note-head::stem-attachment font head-glyph-name))
          (stem-thickness (* size-factor 0.13))
          (stemy (* dir stem-length))
          (attach-off (cons (interval-index
                            (ly:stencil-extent head-glyph X)
-                           (* dir (car attach-indices)))
-                          (* dir       ; fixme, this is inconsistent between X & Y.
+                           (* (sign dir) (car attach-indices)))
+                          (* (sign dir)        ; fixme, this is inconsistent between X & Y.
                              (interval-index
                               (ly:stencil-extent head-glyph Y)
                               (cdr attach-indices)))))
          (stem-glyph (and (> log 0)
                          (ly:round-filled-box
                           (ordered-cons (car attach-off)
-                                        (+ (car attach-off)  (* (- dir) stem-thickness)))
+                                        (+ (car attach-off)  (* (- (sign dir)) stem-thickness)))
                           (cons (min stemy (cdr attach-off))
                                 (max stemy (cdr attach-off)))
                           (/ stem-thickness 3))))
@@ -1335,21 +1351,26 @@ and/or @code{extra-offset} properties. "
 (define-markup-command (fraction layout props arg1 arg2) (markup? markup?)
   "Make a fraction of two markups."
   (let* ((m1 (interpret-markup layout props arg1))
-         (m2 (interpret-markup layout props arg2)))
+         (m2 (interpret-markup layout props arg2))
+         (factor (magstep (chain-assoc-get 'font-size props 0)))
+         (boxdimen (cons (* factor -0.05) (* factor 0.05)))
+         (padding (* factor 0.2))
+         (baseline (* factor 0.6))
+         (offset (* factor 0.75)))
     (set! m1 (ly:stencil-aligned-to m1 X CENTER))
     (set! m2 (ly:stencil-aligned-to m2 X CENTER))
     (let* ((x1 (ly:stencil-extent m1 X))
            (x2 (ly:stencil-extent m2 X))
-           (line (ly:round-filled-box (interval-union x1 x2) '(-0.05 . 0.05) 0.0))
+           (line (ly:round-filled-box (interval-union x1 x2) boxdimen 0.0))
            ;; should stack mols separately, to maintain LINE on baseline
-           (stack (stack-lines -1 0.2 0.6 (list m1 line m2))))
+           (stack (stack-lines DOWN padding baseline (list m1 line m2))))
       (set! stack
            (ly:stencil-aligned-to stack Y CENTER))
       (set! stack
            (ly:stencil-aligned-to stack X LEFT))
       ;; should have EX dimension
       ;; empirical anyway
-      (ly:stencil-translate-axis stack 0.75 Y))))
+      (ly:stencil-translate-axis stack offset Y))))