scm/markup.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2003--2011 Han-Wen Nienhuys <hanwen@xs4all.nl>
   4 ;;;;
   5 ;;;; LilyPond is free software: you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation, either version 3 of the License, or
   8 ;;;; (at your option) any later version.
   9 ;;;;
  10 ;;;; LilyPond is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 (defmacro*-public markup (#:rest body)
  19   "The `markup' macro provides a lilypond-like syntax for building markups.
  20
  21  - #:COMMAND is used instead of \\COMMAND
  22  - #:line ( ... ) is used instead of \\line { ... }
  23  - etc.
  24
  25 Example:
  26   \\markup { foo
  27             \\raise #0.2 \\hbracket \\bold bar
  28             \\override #'(baseline-skip . 4)
  29             \\bracket \\column { baz bazr bla }
  30   }
  31          <==>
  32   (markup \"foo\"
  33           #:raise 0.2 #:hbracket #:bold \"bar\"
  34           #:override '(baseline-skip . 4)
  35           #:bracket #:column (\"baz\" \"bazr\" \"bla\"))"
  36
  37   (car (compile-all-markup-expressions `(#:line ,body))))
  38
  39 ;; utility
  40
  41 (define (markup-join markups sep)
  42   "Return line-markup of MARKUPS, joining them with markup SEP"
  43   (if (pair? markups)
  44       (make-line-markup (list-insert-separator markups sep))
  45       empty-markup))
  46
  47
  48 (define-public interpret-markup ly:text-interface::interpret-markup)
  49
  50 (define-public (interpret-markup-list layout props markup-list)
  51   (let ((stencils (list)))
  52     (for-each (lambda (m)
  53                 (set! stencils
  54                       (if (markup-command-list? m)
  55                           (append! (reverse! (apply (car m) layout props (cdr m)))
  56                                    stencils)
  57                           (cons (interpret-markup layout props m) stencils))))
  58               markup-list)
  59     (reverse! stencils)))
  60
  61 (define-public (prepend-alist-chain key val chain)
  62   (cons (acons key val (car chain)) (cdr chain)))
  63
  64 (define-public (stack-stencil-line space stencils)
  65   "DOCME"
  66   (if (and (pair? stencils)
  67            (ly:stencil? (car stencils)))
  68
  69       (if (and (pair? (cdr stencils))
  70                (ly:stencil? (cadr stencils)))
  71           (let* ((tail (stack-stencil-line space (cdr stencils)))
  72                  (head (car stencils))
  73                  (xoff (+ space (interval-length (ly:stencil-extent head X)))))
  74             (ly:stencil-add head
  75                             (ly:stencil-translate-axis tail xoff X)))
  76           (car stencils))
  77       (ly:make-stencil '() '(0 . 0) '(0 . 0))))
  78
  79
  80 ;;; convert a full markup object to an approximate pure string representation
  81
  82 (define-public (markup->string m)
  83   ;; markup commands with one markup argument, formatting ignored
  84   (define markups-first-argument '(list
  85                                    bold-markup box-markup caps-markup dynamic-markup finger-markup
  86                                    fontCaps-markup huge-markup italic-markup large-markup larger-markup
  87                                    medium-markup normal-size-sub-markup normal-size-super-markup
  88                                    normal-text-markup normalsize-markup number-markup roman-markup
  89                                    sans-markup simple-markup small-markup smallCaps-markup smaller-markup
  90                                    sub-markup super-markup teeny-markup text-markup tiny-markup
  91                                    typewriter-markup underline-markup upright-markup bracket-markup
  92                                    circle-markup hbracket-markup parenthesize-markup rounded-box-markup
  93
  94                                    center-align-markup center-column-markup column-markup dir-column-markup
  95                                    fill-line-markup justify-markup justify-string-markup left-align-markup
  96                                    left-column-markup line-markup right-align-markup right-column-markup
  97                                    vcenter-markup wordwrap-markup wordwrap-string-markup ))
  98
  99   ;; markup commands with markup as second argument, first argument
 100   ;; specifies some formatting and is ignored
 101   (define markups-second-argument '(list
 102                                     abs-fontsize-markup fontsize-markup magnify-markup lower-markup
 103                                     pad-around-markup pad-markup-markup pad-x-markup raise-markup
 104                                     halign-markup hcenter-in-markup rotate-markup translate-markup
 105                                     translate-scaled-markup with-url-markup scale-markup ))
 106
 107   ;; helper functions to handle string cons like string lists
 108   (define (markup-cons->string-cons c)
 109     (if (not (pair? c)) (markup->string c)
 110         (cons (markup->string (car c)) (markup-cons->string-cons (cdr c)))))
 111   (define (string-cons-join c)
 112     (if (not (pair? c)) c
 113         (string-join (list (car c) (string-cons-join (cdr c))) "")))
 114
 115   (cond
 116    ((string? m) m)
 117    ((null? m) "")
 118
 119    ;; handle \concat (string-join without spaces)
 120    ((and (pair? m) (equal? (car m) concat-markup))
 121     (string-cons-join (markup-cons->string-cons (cadr m))) )
 122
 123    ;; markup functions with the markup as first arg
 124    ((member (car m) (primitive-eval markups-first-argument))
 125     (markup->string (cadr m)))
 126
 127    ;; markup functions with markup as second arg
 128    ((member (car m) (primitive-eval markups-second-argument))
 129     (markup->string (cddr m)))
 130
 131    ;; ignore all other markup functions
 132    ((markup-function? (car m)) "")
 133
 134    ;; handle markup lists
 135    ((list? m)
 136     (string-join (map markup->string m) " "))
 137
 138    (else "ERROR, unable to extract string from markup")))