definitions/markup.ly

   1 %------------------------------------------------------------------%
   2 % Opéra Libre -- markup.ly                                         %
   3 %                                                                  %
   4 % (c) Valentin Villenave, 2008                                     %
   5 %                                                                  %
   6 %------------------------------------------------------------------%
   7
   8 %%% The following functions were provided by
   9 %%% Nicolas Sceaux <nicolas.sceaux@free.fr>
  10
  11 #(define-markup-command (copyright layout props) ()
  12   (let* ((maintainer (chain-assoc-get 'header:maintainer props))
  13          (this-year (+ 1900 (tm:year (gmtime (current-time)))))
  14          (year (string->number (or (chain-assoc-get 'header:copyrightYear props)
  15                                    (number->string this-year)))))
  16     (interpret-markup layout props
  17      (markup "Copyright ©"
  18              (if (= year this-year)
  19                  (format #f "~a" this-year)
  20                  (format #f "~a-~a" year this-year))
  21              maintainer))))
  22
  23 #(define-markup-command (when-property layout props symbol markp) (symbol? markup?)
  24   (if (chain-assoc-get symbol props)
  25       (interpret-markup layout props markp)
  26       (ly:make-stencil '()  '(1 . -1) '(1 . -1))))
  27
  28 #(define-markup-command (line-width-ratio layout props width-ratio arg) (number? markup?)
  29   (interpret-markup layout props
  30    (markup #:override (cons 'line-width (* width-ratio (chain-assoc-get 'line-width props)))
  31            arg)))
  32
  33 #(define-markup-list-command (wordwrap-center-lines layout props args)
  34   (markup-list?)
  35   (map (lambda (stencil)
  36         (interpret-markup layout props (markup #:fill-line (#:stencil stencil))))
  37    (interpret-markup-list layout props (make-wordwrap-lines-markup-list args))))
  38
  39 #(define-markup-command (wordwrap-center layout props args) (markup-list?)
  40   (interpret-markup layout props
  41    (make-column-markup
  42     (make-wordwrap-center-lines-markup-list args))))
  43
  44
  45 #(define (page-ref-aux layout props label gauge next)
  46   (let* ((gauge-stencil (interpret-markup layout props gauge))
  47    (x-ext (ly:stencil-extent gauge-stencil X))
  48    (y-ext (ly:stencil-extent gauge-stencil Y)))
  49     (ly:make-stencil
  50      `(delay-stencil-evaluation
  51        ,(delay (ly:stencil-expr
  52     (let* ((table (ly:output-def-lookup layout 'label-page-table))
  53            (label-page (and (list? table) (assoc label table)))
  54            (page-number (and label-page (cdr label-page)))
  55            (page-markup (if page-number
  56                                         (markup #:concat ((format "~a" page-number) next))
  57                                         "?"))
  58            (page-stencil (interpret-markup layout props page-markup))
  59            (gap (- (interval-length x-ext)
  60              (interval-length (ly:stencil-extent page-stencil X)))))
  61       (interpret-markup layout props
  62             (markup #:concat (page-markup #:hspace gap)))))))
  63      x-ext
  64      y-ext)))
  65
  66 #(define-markup-command (page-refI layout props label next)
  67   (symbol? markup?)
  68   (page-ref-aux layout props label "0" next))
  69
  70 #(define-markup-command (page-refII layout props label next)
  71   (symbol? markup?)
  72   (page-ref-aux layout props label "00" next))
  73
  74 #(define-markup-command (page-refIII layout props label next)
  75   (symbol? markup?)
  76   (page-ref-aux layout props label "000" next))
  77
  78 #(define-markup-command (super layout props arg) (markup?)
  79   (ly:stencil-translate-axis
  80    (interpret-markup
  81     layout
  82     (cons `((font-size . ,(- (chain-assoc-get 'font-size props 0) 3))) props)
  83     arg)
  84    (* 0.25 (chain-assoc-get 'baseline-skip props))
  85    Y))
  86
  87 #(define-markup-list-command (paragraph paper props text) (markup-list?)
  88   (let ((indentation (markup #:pad-to-box (cons 0 3) (cons 0 0) #:null)))
  89    (interpret-markup-list paper props
  90     (make-override-lines-markup-list '(baseline-skip . 0)
  91      (make-justified-lines-markup-list (cons indentation text))))))
  92
  93 #(define-markup-list-command (columns paper props text) (markup-list?)
  94   (interpret-markup-list paper props
  95    (make-override-lines-markup-list '(baseline-skip . 1)
  96     (make-column-lines-markup-list text))))
  97
  98 #(define-markup-command (boxed-justify layout props text) (markup-list?)
  99   (interpret-markup layout props
 100    (make-override-markup '(box-padding . 1)
 101     (make-box-markup
 102      (make-column-markup
 103       (make-justified-lines-markup-list text))))))
 104
 105 %%% Guile does not deal with accented letters
 106 #(use-modules (ice-9 regex))
 107 %%;; actually defined below, in a closure
 108 #(define-public string-upper-case #f)
 109 #(define accented-char-upper-case? #f)
 110 #(define accented-char-lower-case? #f)
 111
 112 %%;; an accented character is seen as two characters by guile
 113 #(let ((lower-case-accented-string "éèêëáàâäíìîïóòôöúùûüçœæ")
 114        (upper-case-accented-string "ÉÈÊËÁÀÂÄÍÌÎÏÓÒÔÖÚÙÛÜÇŒÆ"))
 115    (define (group-by-2 chars result)
 116       (if (or (null? chars) (null? (cdr chars)))
 117           (reverse! result)
 118           (group-by-2 (cddr chars)
 119                       (cons (string (car chars) (cadr chars))
 120                             result))))
 121    (let ((lower-case-accented-chars
 122           (group-by-2 (string->list lower-case-accented-string) (list)))
 123          (upper-case-accented-chars
 124           (group-by-2 (string->list upper-case-accented-string) (list))))
 125      (set! string-upper-case
 126            (lambda (str)
 127              (define (replace-chars str froms tos)
 128                (if (null? froms)
 129                    str
 130                    (replace-chars (regexp-substitute/global #f (car froms) str
 131                                                             'pre (car tos) 'post)
 132                                   (cdr froms)
 133                                   (cdr tos))))
 134              (string-upcase (replace-chars str
 135                                            lower-case-accented-chars
 136                                            upper-case-accented-chars))))
 137      (set! accented-char-upper-case?
 138            (lambda (char1 char2)
 139              (member (string char1 char2) upper-case-accented-chars string=?)))
 140      (set! accented-char-lower-case?
 141            (lambda (char1 char2)
 142              (member (string char1 char2) lower-case-accented-chars string=?)))))
 143
 144 #(define-markup-command (smallCaps layout props text) (markup?)
 145   "Turn @code{text}, which should be a string, to small caps.
 146 @example
 147 \\markup \\small-caps \"Text between double quotes\"
 148 @end example"
 149   (define (string-list->markup strings lower)
 150     (let ((final-string (string-upper-case
 151                          (apply string-append (reverse strings)))))
 152       (if lower
 153           (markup #:fontsize -2 final-string)
 154           final-string)))
 155   (define (make-small-caps rest-chars currents current-is-lower prev-result)
 156     (if (null? rest-chars)
 157         (make-concat-markup (reverse! (cons (string-list->markup
 158                                               currents current-is-lower)
 159                                             prev-result)))
 160         (let* ((ch1 (car rest-chars))
 161                (ch2 (and (not (null? (cdr rest-chars))) (cadr rest-chars)))
 162                (this-char-string (string ch1))
 163                (is-lower (char-lower-case? ch1))
 164                (next-rest-chars (cdr rest-chars)))
 165           (cond ((and ch2 (accented-char-lower-case? ch1 ch2))
 166                  (set! this-char-string (string ch1 ch2))
 167                  (set! is-lower #t)
 168                  (set! next-rest-chars (cddr rest-chars)))
 169                 ((and ch2 (accented-char-upper-case? ch1 ch2))
 170                  (set! this-char-string (string ch1 ch2))
 171                  (set! is-lower #f)
 172                  (set! next-rest-chars (cddr rest-chars))))
 173           (if (or (and current-is-lower is-lower)
 174                   (and (not current-is-lower) (not is-lower)))
 175               (make-small-caps next-rest-chars
 176                                (cons this-char-string currents)
 177                                is-lower
 178                                prev-result)
 179               (make-small-caps next-rest-chars
 180                                (list this-char-string)
 181                                is-lower
 182                                (if (null? currents)
 183                                    prev-result
 184                                    (cons (string-list->markup
 185                                             currents current-is-lower)
 186                                          prev-result)))))))
 187   (interpret-markup layout props
 188     (if (string? text)
 189         (make-small-caps (string->list text) (list) #f (list))
 190         text)))
 191
 192 %%%
 193 %%% Markup commands
 194 %%%
 195 #(define-markup-command (rehearsal-number layout props text) (string?)
 196    (interpret-markup layout props
 197      (markup #:huge #:bold text)))
 198
 199 #(define-markup-command (rehearsal-number-toc layout props text) (string?)
 200   (let* ((gauge-stencil (interpret-markup layout props "8-88"))
 201    (x-ext (ly:stencil-extent gauge-stencil X))
 202    (y-ext (ly:stencil-extent gauge-stencil Y))
 203          (stencil (interpret-markup layout props text))
 204          (gap (- (interval-length x-ext)
 205                  (interval-length (ly:stencil-extent stencil X)))))
 206     (interpret-markup layout props
 207       (markup #:concat (#:hspace gap text #:hspace 1)))))
 208
 209 #(define-markup-command (act layout props arg) (markup?)
 210   (interpret-markup layout props
 211     (if (*part*)
 212         (markup #:pad-markup 2 #:fill-line (#:fontsize 6 arg))
 213         (markup #:column (#:vspace 3
 214                           #:pad-markup 3 #:fill-line (#:fontsize 6 arg))))))
 215
 216 #(define-markup-command (scene layout props arg) (markup?)
 217   (interpret-markup layout props
 218     (if (*part*)
 219         (markup #:pad-markup 0.5 #:fill-line (#:fontsize 4 arg))
 220         (markup #:column (#:vspace 1
 221                           #:fill-line (#:fontsize 4 arg)
 222                           #:vspace 1)))))
 223
 224 #(define-markup-command (scene-description layout props arg) (markup?)
 225   (interpret-markup layout props
 226     (if (*part*)
 227         empty-markup
 228         (markup #:column (#:fill-line (#:override '(line-width . 80)
 229                                        #:fontsize 2 arg)
 230                           #:vspace 1)))))
 231
 232 #(define-markup-command (title layout props arg) (markup?)
 233   (interpret-markup layout props
 234    (markup #:fill-line (#:override '(line-width . 80)
 235                         #:fontsize 2 arg))))
 236
 237 #(define-markup-command (small-title layout props arg) (markup?)
 238   (interpret-markup layout props
 239    (markup #:fill-line (#:override '(line-width . 80)
 240                         #:fontsize 0 #:italic arg))))
 241
 242
 243 #(define-markup-command (characteri paper props name) (markup?)
 244   (interpret-markup paper props
 245    (markup #:huge #:smallCaps name)))
 246
 247 #(define-markup-command (character paper props name) (markup?)
 248   (interpret-markup paper props
 249    (markup #:null #:translate  (cons -4 2) #:characteri name)))
 250
 251 #(define-markup-command (character-text paper props name text) (markup? markup?)
 252   (interpret-markup paper props
 253    (markup #:null #:translate  (cons -4 2)
 254     #:line (#:characteri name #:huge " " #:huge #:italic text))))
 255
 256 #(define-public (make-character-mark clefs name)
 257   #{ << { \set Staff.forceClef = ##t \clef #$clefs
 258           \once \override Staff . Clef #'full-size-change = ##t }
 259         s1*0 ^\markup \character $name >> #})
 260
 261