Merge branch 'master' of ssh://kainhofer@git.sv.gnu.org/srv/git/lilypond into dev...

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

diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm
index 4cffe4c248279435865597612bd2bc979c73a5d7..0b9e7c954026a84d0b47715460df97e53f2a53f2 100644 (file)
--- a/scm/define-markup-commands.scm
+++ b/scm/define-markup-commands.scm
@@ -2,7 +2,7 @@
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;; 
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;; 

-;;;; (c) 2000--2006  Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; (c) 2000--2007  Han-Wen Nienhuys <hanwen@xs4all.nl>

 ;;;;                  Jan Nieuwenhuizen <janneke@gnu.org>
 
 
 ;;;;                  Jan Nieuwenhuizen <janneke@gnu.org>
 
 


@@ -28,7 +28,9 @@
   (number-pair?)
   "A simple line.  Uses the @code{thickness} property."
   (let*
   (number-pair?)
   "A simple line.  Uses the @code{thickness} property."
   (let*

-      ((th (chain-assoc-get 'thickness props  0.1))
+      ((th (*
+           (ly:output-def-lookup layout 'line-thickness)
+           (chain-assoc-get 'thickness props 1)))

        (x (car dest))
        (y (cdr dest))
        (s (ly:make-stencil
        (x (car dest))
        (y (cdr dest))
        (s (ly:make-stencil


@@ -74,7 +76,9 @@ optionally filled."
 @code{circle-padding} and @code{font-size} properties to determine line
 thickness and padding around the markup."
   
 @code{circle-padding} and @code{font-size} properties to determine line
 thickness and padding around the markup."
   

-  (let* ((th (chain-assoc-get 'thickness props  0.1))
+  (let* ((th
+         (* (ly:output-def-lookup layout 'line-thickness)
+            (chain-assoc-get 'thickness props  1)))

         (size (chain-assoc-get 'font-size props 0))
         (pad
          (* (magstep size)
         (size (chain-assoc-get 'font-size props 0))
         (pad
          (* (magstep size)


@@ -113,12 +117,30 @@ the PDF backend."
      (cons (+ (- half) (car yext))
           (+ half (cdr yext))))))
 
      (cons (+ (- half) (car yext))
           (+ half (cdr yext))))))
 

+(define-builtin-markup-command (underline layout props arg) (markup?)
+  "Underline @var{arg}.  Looks at @code{thickness} to determine line
+thickness and y offset."
+  (let* ((thick (*
+             (ly:output-def-lookup layout 'line-thickness)
+             (chain-assoc-get 'thickness props 1)))
+        (markup (interpret-markup layout props arg))
+        (x1 (car (ly:stencil-extent markup X)))
+        (x2 (cdr (ly:stencil-extent markup X)))
+        (y (* thick -2))
+        (line (ly:make-stencil
+               `(draw-line ,thick ,x1 ,y ,x2 ,y)
+               (cons (min x1 0) (max x2 0))
+               (cons thick thick))))
+        (ly:stencil-add markup line)))
+

 (define-builtin-markup-command (box layout props arg) (markup?)
   "Draw a box round @var{arg}.  Looks at @code{thickness},
 @code{box-padding} and @code{font-size} properties to determine line
 thickness and padding around the markup."
   
 (define-builtin-markup-command (box layout props arg) (markup?)
   "Draw a box round @var{arg}.  Looks at @code{thickness},
 @code{box-padding} and @code{font-size} properties to determine line
 thickness and padding around the markup."
   

-  (let* ((th (chain-assoc-get 'thickness props  0.1))
+  (let* ((th (*
+             (ly:output-def-lookup layout 'line-thickness)
+             (chain-assoc-get 'thickness props 1)))

         (size (chain-assoc-get 'font-size props 0))
         (pad (* (magstep size)
                 (chain-assoc-get 'box-padding props 0.2)))
         (size (chain-assoc-get 'font-size props 0))
         (pad (* (magstep size)
                 (chain-assoc-get 'box-padding props 0.2)))


@@ -347,9 +369,7 @@ grestore
 The markups are spaced or flushed to fill the entire line.
 If there are no arguments, return an empty stencil."
  
 The markups are spaced or flushed to fill the entire line.
 If there are no arguments, return an empty stencil."
  

-  (let* ((orig-stencils
-         (map (lambda (x) (interpret-markup layout props x))
-              markups))
+  (let* ((orig-stencils (interpret-markup-list layout props markups))

         (stencils
          (map (lambda (stc)
                 (if (ly:stencil-empty? stc)
         (stencils
          (map (lambda (stc)
                 (if (ly:stencil-empty? stc)


@@ -405,7 +425,7 @@ If there are no arguments, return an empty stencil."
   "Put @var{args} in a horizontal line.  The property @code{word-space}
 determines the space between each markup in @var{args}."
   (let*
   "Put @var{args} in a horizontal line.  The property @code{word-space}
 determines the space between each markup in @var{args}."
   (let*

-      ((stencils (map (lambda (m) (interpret-markup layout props m)) args))
+      ((stencils (interpret-markup-list layout props args))

        (space    (chain-assoc-get 'word-space props))
        (text-dir (chain-assoc-get 'text-direction props RIGHT)) 
        )
        (space    (chain-assoc-get 'word-space props))
        (text-dir (chain-assoc-get 'text-direction props RIGHT)) 
        )


@@ -439,7 +459,9 @@ equivalent to @code{\"fi\"}."
 
   (interpret-markup layout
                     (prepend-alist-chain 'word-space 0 props)
 
   (interpret-markup layout
                     (prepend-alist-chain 'word-space 0 props)

-                    (make-line-markup (concat-string-args args))))
+                    (make-line-markup (if (markup-command-list? args)
+                                         args
+                                         (concat-string-args args)))))

 
 (define (wordwrap-stencils stencils
                           justify base-space line-width text-dir)
 
 (define (wordwrap-stencils stencils
                           justify base-space line-width text-dir)


@@ -521,32 +543,28 @@ equivalent to @code{\"fi\"}."
 
 (define (wordwrap-markups layout props args justify)
   (let*
 
 (define (wordwrap-markups layout props args justify)
   (let*

-      ((baseline-skip (chain-assoc-get 'baseline-skip props))
-       (prop-line-width (chain-assoc-get 'line-width props #f))
+      ((prop-line-width (chain-assoc-get 'line-width props #f))

        (line-width (if prop-line-width prop-line-width
                       (ly:output-def-lookup layout 'line-width)))
        (word-space (chain-assoc-get 'word-space props))
        (line-width (if prop-line-width prop-line-width
                       (ly:output-def-lookup layout 'line-width)))
        (word-space (chain-assoc-get 'word-space props))

-       (text-dir (chain-assoc-get 'text-direction props RIGHT)) 
-       (lines (wordwrap-stencils
-              (remove ly:stencil-empty?
-                      (map (lambda (m) (interpret-markup layout props m)) args))
-              justify word-space line-width
-              text-dir)
-              ))
-
-    (stack-lines DOWN 0.0 baseline-skip lines)))
+       (text-dir (chain-assoc-get 'text-direction props RIGHT)))
+    (wordwrap-stencils (remove ly:stencil-empty?
+                               (interpret-markup-list layout props args))
+                       justify word-space line-width
+                       text-dir)))

 
 (define-builtin-markup-command (justify layout props args) (markup-list?)
   "Like wordwrap, but with lines stretched to justify the margins.
 Use @code{\\override #'(line-width . @var{X})} to set the line width;
 @var{X}@tie{}is the number of staff spaces."
 
 (define-builtin-markup-command (justify layout props args) (markup-list?)
   "Like wordwrap, but with lines stretched to justify the margins.
 Use @code{\\override #'(line-width . @var{X})} to set the line width;
 @var{X}@tie{}is the number of staff spaces."

-  (wordwrap-markups layout props args #t))
+  (stack-lines DOWN 0.0 (chain-assoc-get 'baseline-skip props)
+              (wordwrap-markups layout props args #t)))

 
 (define-builtin-markup-command (wordwrap layout props args) (markup-list?)
   "Simple wordwrap.  Use @code{\\override #'(line-width . @var{X})} to set
 the line width, where @var{X} is the number of staff spaces."
 
 (define-builtin-markup-command (wordwrap layout props args) (markup-list?)
   "Simple wordwrap.  Use @code{\\override #'(line-width . @var{X})} to set
 the line width, where @var{X} is the number of staff spaces."

-
-  (wordwrap-markups layout props args #f))
+  (stack-lines DOWN 0.0 (chain-assoc-get 'baseline-skip props)
+              (wordwrap-markups layout props args #f)))

 
 (define (wordwrap-string layout props justify arg) 
   (let*
 
 (define (wordwrap-string layout props justify arg) 
   (let*


@@ -624,7 +642,7 @@ the line width, where @var{X} is the number of staff spaces."
 @code{baseline-skip} determines the space between each markup in @var{args}."
 
   (let*
 @code{baseline-skip} determines the space between each markup in @var{args}."
 
   (let*

-      ((arg-stencils (map (lambda (m) (interpret-markup layout props m)) args))
+      ((arg-stencils (interpret-markup-list layout props args))

        (skip (chain-assoc-get 'baseline-skip props)))
 
     
        (skip (chain-assoc-get 'baseline-skip props)))
 
     


@@ -641,11 +659,11 @@ of the @code{#'direction} layout property."
      (if (number? dir) dir -1)
      0.0
      (chain-assoc-get 'baseline-skip props)
      (if (number? dir) dir -1)
      0.0
      (chain-assoc-get 'baseline-skip props)

-     (map (lambda (x) (interpret-markup layout props x)) args))))
+     (interpret-markup-list layout props args))))

 
 (define-builtin-markup-command (center-align layout props args) (markup-list?)
   "Put @code{args} in a centered column."
 
 (define-builtin-markup-command (center-align layout props args) (markup-list?)
   "Put @code{args} in a centered column."

-  (let* ((mols (map (lambda (x) (interpret-markup layout props x)) args))
+  (let* ((mols (interpret-markup-list layout props args))

          (cmols (map (lambda (x) (ly:stencil-aligned-to x X CENTER)) mols)))
     
     (stack-lines -1 0.0 (chain-assoc-get 'baseline-skip props) cmols)))
          (cmols (map (lambda (x) (ly:stencil-aligned-to x X CENTER)) mols)))
     
     (stack-lines -1 0.0 (chain-assoc-get 'baseline-skip props) cmols)))


@@ -922,65 +940,40 @@ some punctuation.  It doesn't have any letters."
   "Turn @code{text}, which should be a string, to small caps.
 @example
 \\markup \\smallCaps \"Text between double quotes\"
   "Turn @code{text}, which should be a string, to small caps.
 @example
 \\markup \\smallCaps \"Text between double quotes\"

-@end example"
-  (define (make-small-caps-markup chars)
-    (cond ((null? chars)
-          (markup))
-         ((char-whitespace? (car chars))
-          (markup #:fontsize -2 #:simple (string-upcase (list->string (cdr chars)))))
-         (else
-          (markup #:hspace -1
-                  #:fontsize -2 #:simple (string-upcase (list->string chars))))))
-  (define (make-not-small-caps-markup chars)
-    (cond ((null? chars)
-          (markup))
-         ((char-whitespace? (car chars))
-          (markup #:simple (list->string (cdr chars))))
-         (else
-          (markup #:hspace -1
-                  #:simple (list->string chars)))))
-  (define (small-caps-aux done-markups current-chars rest-chars small? after-space?)
-    (cond ((null? rest-chars)
-          ;; the end of the string: build the markup
-          (make-line-markup (reverse! (cons ((if small?
-                                                 make-small-caps-markup
-                                                 make-not-small-caps-markup)
-                                             (reverse! current-chars))
-                                            done-markups))))
-         ((char-whitespace? (car rest-chars))
-          ;; a space char.
-          (small-caps-aux done-markups current-chars (cdr rest-chars) small? #t))
-         ((or (and small? (char-lower-case? (car rest-chars)))
-              (and (not small?) (not (char-lower-case? (car rest-chars)))))
-          ;; same case
-          ;; add the char to the current char list
-          (small-caps-aux done-markups
-                          (cons (car rest-chars)
-                                (if after-space? 
-                                    (cons #\space current-chars)
-                                    current-chars))
-                          (cdr rest-chars) 
-                          small?
-                          #f))
-         (else
-          ;; case change
-          ;; make a markup with current chars, and start a new list with new char
-          (small-caps-aux (cons ((if small?
-                                     make-small-caps-markup
-                                     make-not-small-caps-markup)
-                                 (reverse! current-chars))
-                                done-markups)
-                          (if after-space?
-                              (list (car rest-chars) #\space)
-                              (list (car rest-chars)))
-                          (cdr rest-chars)
-                          (not small?)
-                          #f))))
-  (interpret-markup layout props (small-caps-aux (list) 
-                                                (list) 
-                                                (cons #\space (string->list text))
-                                                #f
-                                                #f)))
+@end example
+
+Note: @code{\\smallCaps} does not support accented characters."
+  (define (char-list->markup chars lower)
+    (let ((final-string (string-upcase (reverse-list->string chars))))
+      (if lower
+         (markup #:fontsize -2 final-string)
+         final-string)))
+  (define (make-small-caps rest-chars currents current-is-lower prev-result)
+    (if (null? rest-chars)
+       (make-concat-markup
+         (reverse! (cons (char-list->markup currents current-is-lower)
+                         prev-result)))
+       (let* ((ch (car rest-chars))
+              (is-lower (char-lower-case? ch)))
+         (if (or (and current-is-lower is-lower)
+                 (and (not current-is-lower) (not is-lower)))
+             (make-small-caps (cdr rest-chars)
+                              (cons ch currents)
+                              is-lower
+                              prev-result)
+             (make-small-caps (cdr rest-chars)
+                              (list ch)
+                              is-lower
+                              (if (null? currents)
+                                  prev-result
+                                  (cons (char-list->markup
+                                           currents current-is-lower)
+                                        prev-result)))))))
+  (interpret-markup layout props
+    (if (string? text)
+       (make-small-caps (string->list text) (list) #f (list))
+       text)))
+

 
 (define-builtin-markup-command (caps layout props arg) (markup?)
   "Emit @var{arg} as small caps."
 
 (define-builtin-markup-command (caps layout props arg) (markup?)
   "Emit @var{arg} as small caps."


@@ -1105,9 +1098,9 @@ Use the filled head if @var{filled} is specified."
      name)))
 
 (define-builtin-markup-command (musicglyph layout props glyph-name) (string?)
      name)))
 
 (define-builtin-markup-command (musicglyph layout props glyph-name) (string?)

-  "@var{glyph0name} is converted to a musical symbol; for example,
+  "@var{glyph-name} is converted to a musical symbol; for example,

 @code{\\musicglyph #\"accidentals.natural\"} selects the natural sign from
 @code{\\musicglyph #\"accidentals.natural\"} selects the natural sign from

-the music font.  See @usermanref{The Feta font} for a complete listing of
+the music font.  See @ruser{The Feta font} for a complete listing of

 the possible glyphs."
   (ly:font-get-glyph
    (ly:paper-get-font layout (cons '((font-encoding . fetaMusic))
 the possible glyphs."
   (ly:font-get-glyph
    (ly:paper-get-font layout (cons '((font-encoding . fetaMusic))


@@ -1168,7 +1161,8 @@ figured bass notation."
       ((mag (magstep (chain-assoc-get 'font-size props 0)))
        (thickness
        (* mag
       ((mag (magstep (chain-assoc-get 'font-size props 0)))
        (thickness
        (* mag

-          (chain-assoc-get 'thickness props 0.16)))
+          (ly:output-def-lookup layout 'line-thickness)
+          (chain-assoc-get 'thickness props 1.6)))

        (dy (* mag 0.15))
        (number-stencil (interpret-markup layout
                                         (prepend-alist-chain 'font-encoding 'fetaNumber props)
        (dy (* mag 0.15))
        (number-stencil (interpret-markup layout
                                         (prepend-alist-chain 'font-encoding 'fetaNumber props)


@@ -1491,3 +1485,41 @@ when @var{label} is not found."
                                    (markup #:concat (#:hspace gap page-markup)))))))
      x-ext
      y-ext)))
                                    (markup #:concat (#:hspace gap page-markup)))))))
      x-ext
      y-ext)))

+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Markup list commands
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-public (space-lines baseline-skip lines)
+  (map (lambda (line)
+        (stack-lines DOWN 0.0 (/ baseline-skip 2.0)
+                     (list (ly:make-stencil "" (cons 0 0) (cons 0 0))
+                           line
+                           (ly:make-stencil "" (cons 0 0) (cons 0 0)))))
+       lines))
+
+(define-builtin-markup-list-command (justified-lines layout props args) (markup-list?)
+  "Like @code{\\justify}, but return a list of lines instead of a single markup.
+Use @code{\\override-lines #'(line-width . @var{X})} to set the line width;
+@var{X}@tie{}is the number of staff spaces."
+  (space-lines (chain-assoc-get 'baseline-skip props)
+              (wordwrap-markups layout props args #t)))
+
+(define-builtin-markup-list-command (wordwrap-lines layout props args) (markup-list?)
+  "Like @code{\\wordwrap}, but return a list of lines instead of a single markup.
+Use @code{\\override-lines #'(line-width . @var{X})} to set the line width,
+where @var{X} is the number of staff spaces."
+  (space-lines (chain-assoc-get 'baseline-skip props)
+              (wordwrap-markups layout props args #f)))
+
+(define-builtin-markup-list-command (column-lines layout props args) (markup-list?)
+  "Like @code{\\column}, but return a list of lines instead of a single markup.
+@code{baseline-skip} determines the space between each markup in @var{args}."
+  (space-lines (chain-assoc-get 'baseline-skip props)
+              (interpret-markup-list layout props args)))
+
+(define-builtin-markup-list-command (override-lines layout props new-prop args)
+  (pair? markup-list?)
+  "Like @code{\\override}, for markup lists."
+  (interpret-markup-list layout (cons (list new-prop) props) args))