common/markup.ily

   1 %%% markup.ily -- generic markup commands
   2 %%%
   3 %%% Author: Nicolas Sceaux <nicolas.sceaux@free.fr>
   4 %%%
   5 %%% Markup commands
   6 %%% ===============
   7 %%%   \vspace <amount>
   8 %%%     like \hspace, but for vertical space
   9 %%%
  10 %%%   \smallCaps <string>
  11 %%%     like built-in \smallCaps, but dealing with accented letters
  12 %%%
  13 %%%   \when-property <symbol> <markup>
  14 %%%     if symbol is find in properties, interpret the markup
  15 %%%     otherwise, return an empty stencil
  16 %%%
  17 %%%   \line-width-ratio <ratio> <markup>
  18 %%%     interpret markup with a line-width set to current line-width * ratio
  19 %%%
  20 %%%   \copyright
  21 %%%     build a copyight line, using the maintainer and copyrightYear
  22 %%%     header variables.
  23 %%%
  24 %%%   \wordwrap-center <markup-list>
  25 %%%     like wordwrap, but center align the lines
  26 %%%
  27 %%% Markup lines commands
  28 %%% =====================
  29 %%%   \wordwrap-center-lines <markup-list>
  30 %%%     make a markup list composed centered lines of text.
  31
  32 %%% Redefinition of \column, \justify and \wordwrap
  33 %%% to fix spacing around blocks
  34 #(define-markup-command (column layout props args) (markup-list?)
  35    #:properties ((baseline-skip))
  36    (let ((arg-stencils (interpret-markup-list layout props args)))
  37      (stack-lines DOWN 0.0 0
  38                   (space-lines baseline-skip
  39                                (remove ly:stencil-empty? arg-stencils)))))
  40
  41 #(define-markup-command (justify layout props args)
  42      (markup-list?)
  43    #:properties ((baseline-skip)
  44                  wordwrap-internal-markup-list)
  45    (stack-lines
  46     DOWN 0.0 0
  47     (space-lines baseline-skip
  48                  (wordwrap-internal-markup-list layout props #t args))))
  49
  50 #(define-markup-command (wordwrap layout props args)
  51      (markup-list?)
  52    #:properties ((baseline-skip)
  53                  wordwrap-internal-markup-list)
  54   (stack-lines
  55    DOWN 0.0 0
  56    (space-lines baseline-skip
  57                 (wordwrap-internal-markup-list layout props #f args))))
  58
  59 %%%
  60 %%%
  61
  62 #(define-markup-command (vspace layout props amount) (number?)
  63   "This produces a invisible object taking vertical space."
  64   (let ((amount (* amount 3.0)))
  65     (if (> amount 0)
  66         (ly:make-stencil "" (cons -1 1) (cons 0 amount))
  67         (ly:make-stencil "" (cons -1 1) (cons amount amount)))))
  68
  69 #(define-markup-command (copyright layout props) ()
  70   (let* ((maintainer (chain-assoc-get 'header:maintainer props))
  71          (this-year (+ 1900 (tm:year (gmtime (current-time)))))
  72          (year (string->number (or (chain-assoc-get 'header:copyrightYear props)
  73                                    (number->string this-year)))))
  74     (interpret-markup layout props
  75      (markup "Copyright ©"
  76              (if (= year this-year)
  77                  (format #f "~a" this-year)
  78                  (format #f "~a-~a" year this-year))
  79              maintainer))))
  80
  81 #(define-markup-command (today layout props) ()
  82   (let ((today (gmtime (current-time))))
  83    (interpret-markup layout props
  84      (format #f "~a-~a-~a"
  85              (+ 1900 (tm:year today))
  86              (1+ (tm:mon today))
  87              (tm:mday today)))))
  88
  89 #(define-markup-command (when-property layout props symbol markp) (symbol? markup?)
  90   (if (chain-assoc-get symbol props)
  91       (interpret-markup layout props markp)
  92       (ly:make-stencil '()  '(1 . -1) '(1 . -1))))
  93
  94 #(define-markup-command (apply-fromproperty layout props fn symbol)
  95   (procedure? symbol?)
  96   (let ((m (chain-assoc-get symbol props)))
  97     (if (markup? m)
  98         (interpret-markup layout props (fn m))
  99         empty-stencil)))
 100
 101 #(define-markup-command (line-width-ratio layout props width-ratio arg)
 102   (number? markup?)
 103   (interpret-markup layout props
 104    (markup #:override (cons 'line-width (* width-ratio
 105                                            (chain-assoc-get 'line-width props)))
 106            arg)))
 107
 108 #(define-markup-list-command (line-width-ratio-lines layout props width-ratio args)
 109   (number? markup-list?)
 110   (interpret-markup-list layout props
 111     (make-override-lines-markup-list
 112       (cons 'line-width (* width-ratio
 113                            (chain-assoc-get 'line-width props)))
 114       args)))
 115
 116 #(define-markup-list-command (with-line-width-ratio layout props width-ratio args)
 117   (number? markup-list?)
 118   (let* ((line-width (chain-assoc-get 'line-width props))
 119          (new-line-width (* width-ratio line-width))
 120          (indent (* 0.5 (- line-width new-line-width)))
 121          (stencils (interpret-markup-list layout
 122                      (cons `((line-width . ,new-line-width)) props)
 123                      args)))
 124     (interpret-markup-list layout props
 125       (map (lambda (stencil)
 126              (markup #:hspace indent #:stencil stencil))
 127            stencils))))
 128
 129 #(define-markup-command (force-line-width-ratio layout props ratio arg)
 130      (number? markup?)
 131    (let* ((new-line-width (* ratio (chain-assoc-get 'line-width props)))
 132           (line-stencil (interpret-markup layout props
 133                                   (markup #:override (cons 'line-width new-line-width)
 134                                           arg)))
 135           (gap (max 0
 136                     (- new-line-width
 137                        (interval-length (ly:stencil-extent line-stencil X))))))
 138      (interpret-markup layout props (markup #:concat (#:stencil line-stencil #:hspace gap)))))
 139
 140 #(define-markup-list-command (two-column-lines layout props col1 col2)
 141    (markup-list? markup-list?)
 142    (interpret-markup-list layout props
 143                           (make-column-lines-markup-list
 144                            (let ((result '()))
 145                              (let map-on-lists ((col1 col1)
 146                                                 (col2 col2))
 147                                (if (and (null? col1) (null? col2))
 148                                    (reverse! result)
 149                                    (let ((line-col1 (if (null? col1) "" (car col1)))
 150                                          (line-col2 (if (null? col2) "" (car col2)))
 151                                          (rest-col1 (if (null? col1) '() (cdr col1)))
 152                                          (rest-col2 (if (null? col2) '() (cdr col2))))
 153                                      (set! result (cons
 154                                                    (markup #:fill-line
 155                                                            (#:null
 156                                                             #:force-line-width-ratio 0.45 line-col1
 157                                                             #:null
 158                                                             #:force-line-width-ratio 0.45 line-col2
 159                                                             #:null))
 160                                                    result))
 161                                      (map-on-lists rest-col1 rest-col2))))))))
 162
 163 #(define-markup-command (tacet-lyrics layout props score text)
 164      (markup? markup-list?)
 165    #:properties ((column-number 2))
 166    (interpret-markup
 167     layout props
 168     #{\markup\column {
 169         \fontsize #-2 \override #`(column-number . ,column-number)
 170         \column\page-columns {
 171           \fontsize #2 \line { \hspace #10 Tacet $score }
 172           \null
 173           $text
 174         }
 175       } #}))
 176
 177 #(define-markup-command (lyrics layout props text)
 178      (markup-list?)
 179    #:properties ((column-number 2))
 180    (interpret-markup
 181     layout props
 182     #{\markup\column {
 183         \fontsize #-2 \override #`(column-number . ,column-number)
 184         \column\page-columns { $text } } #}))
 185
 186 #(define-markup-list-command (indented-lines layout props indent args)
 187   (number? markup-list?)
 188   (let* ((new-line-width (- (chain-assoc-get 'line-width props) indent))
 189          (lines (interpret-markup-list layout
 190                  (cons `((line-width . ,new-line-width)) props)
 191                  args)))
 192    (interpret-markup-list layout props
 193     (map (lambda (line)
 194           (markup #:hspace indent #:stencil line))
 195      lines))))
 196
 197 #(define-markup-list-command (wordwrap-center-lines layout props args)
 198   (markup-list?)
 199   (map (lambda (stencil)
 200         (interpret-markup layout props (markup #:fill-line (#:stencil stencil))))
 201    (interpret-markup-list layout props (make-wordwrap-lines-markup-list args))))
 202
 203 #(define-markup-list-command (centered-lines layout props args)
 204   (markup-list?)
 205   (let ((baseline-skip (chain-assoc-get 'baseline-skip props)))
 206     (space-lines baseline-skip
 207       (interpret-markup-list layout props
 208         (map (lambda (arg) (markup #:fill-line (arg)))
 209              args)))))
 210
 211 #(define-markup-list-command (fontsize-lines layout props increment args)
 212    (number? markup-list?)
 213    #:properties ((font-size 0)
 214                  (word-space 1)
 215                  (baseline-skip 2))
 216    (interpret-markup-list layout
 217                           (cons `((baseline-skip . ,(* baseline-skip (magstep increment)))
 218                                   (word-space . ,(* word-space (magstep increment)))
 219                                   (font-size . ,(+ font-size increment)))
 220                                 props)
 221                           args))
 222
 223 #(define-markup-list-command (abs-fontsize-lines layout props size args)
 224   (number? markup-list?)
 225   (let* ((ref-size (ly:output-def-lookup layout 'text-font-size 12))
 226          (text-props (list (ly:output-def-lookup layout 'text-font-defaults)))
 227          (ref-word-space (chain-assoc-get 'word-space text-props 0.6))
 228          (ref-baseline (chain-assoc-get 'baseline-skip text-props 3))
 229          (magnification (/ size ref-size)))
 230     (interpret-markup-list layout
 231                            (cons `((baseline-skip . ,(* magnification ref-baseline))
 232                                    (word-space . ,(* magnification ref-word-space))
 233                                    (font-size . ,(magnification->font-size magnification)))
 234                                  props)
 235                            args)))
 236
 237 #(define-markup-command (wordwrap-center layout props args) (markup-list?)
 238   (interpret-markup layout props
 239    (make-column-markup
 240     (make-wordwrap-center-lines-markup-list args))))
 241
 242 #(define (page-ref-aux layout props label gauge next)
 243   (let* ((gauge-stencil (interpret-markup layout props gauge))
 244          (x-ext (ly:stencil-extent gauge-stencil X))
 245          (y-ext (ly:stencil-extent gauge-stencil Y)))
 246     (ly:make-stencil
 247      `(delay-stencil-evaluation
 248        ,(delay (ly:stencil-expr
 249                 (let* ((table (ly:output-def-lookup layout 'label-page-table))
 250                        (label-page (and (list? table) (assoc label table)))
 251                        (page-number (and label-page (cdr label-page)))
 252                        (page-markup (if page-number
 253                                         (markup #:page-link page-number
 254                                             #:concat ((format "~a" page-number)
 255                                                       next))
 256                                         (markup #:concat ("?" next))))
 257                        (page-stencil (interpret-markup layout props page-markup))
 258                        (gap (- (interval-length x-ext)
 259                                (interval-length (ly:stencil-extent page-stencil X)))))
 260                   (interpret-markup layout props
 261                                     (markup #:concat (page-markup #:hspace gap)))))))
 262      x-ext
 263      y-ext)))
 264
 265 #(define-markup-command (page-refI layout props label next)
 266   (symbol? markup?)
 267   (page-ref-aux layout props label "0" next))
 268
 269 #(define-markup-command (page-refII layout props label next)
 270   (symbol? markup?)
 271   (page-ref-aux layout props label "00" next))
 272
 273 #(define-markup-command (page-refIII layout props label next)
 274   (symbol? markup?)
 275   (page-ref-aux layout props label "000" next))
 276
 277 #(define-markup-command (super layout props arg) (markup?)
 278   (ly:stencil-translate-axis
 279    (interpret-markup
 280     layout
 281     (cons `((font-size . ,(- (chain-assoc-get 'font-size props 0) 3))) props)
 282     arg)
 283    (* 0.25 (chain-assoc-get 'baseline-skip props))
 284    Y))
 285
 286 #(define-markup-list-command (paragraph layout props text) (markup-list?)
 287   (let ((indentation (markup #:pad-to-box (cons 0 3) (cons 0 0) #:null)))
 288     (interpret-markup-list layout props
 289        (make-justified-lines-markup-list (cons indentation text)))))
 290
 291 #(define-markup-list-command (columns paper props text) (markup-list?)
 292   (interpret-markup-list paper props
 293     (make-column-lines-markup-list text)))
 294
 295 #(define-markup-command (separation-line layout props width) (number?)
 296   (interpret-markup layout props
 297    (markup #:fill-line (#:draw-line (cons (/ (* 20 width) (*staff-size*)) 0)))))
 298
 299 #(define-markup-command (sep layout props) ()
 300    (interpret-markup layout props
 301                      (markup #:pad-around 1 #:fill-line (#:draw-line '(50 . 0)))))
 302
 303 #(define-markup-command (boxed-justify layout props text) (markup-list?)
 304   (interpret-markup layout props
 305    (make-override-markup '(box-padding . 1)
 306     (make-box-markup
 307      (make-column-markup
 308       (make-justified-lines-markup-list text))))))
 309
 310 #(define-markup-command (after-system layout props arg) (markup?)
 311    (let ((stencil (interpret-markup layout props arg)))
 312      (ly:make-stencil (ly:stencil-expr (ly:stencil-aligned-to stencil Y DOWN))
 313                       (ly:stencil-extent stencil X)
 314                       '(1 . -1))))
 315
 316 %%% Guile does not deal with accented letters
 317 #(use-modules (ice-9 regex))
 318 %%;; actually defined below, in a closure
 319 #(define-public string-upper-case #f)
 320 #(define accented-char-upper-case? #f)
 321 #(define accented-char-lower-case? #f)
 322
 323 %%;; an accented character is seen as two characters by guile
 324 #(let ((lower-case-accented-string "éèêëáàâäíìîïóòôöúùûüçœæ")
 325        (upper-case-accented-string "ÉÈÊËÁÀÂÄÍÌÎÏÓÒÔÖÚÙÛÜÇŒÆ"))
 326    (define (group-by-2 chars result)
 327       (if (or (null? chars) (null? (cdr chars)))
 328           (reverse! result)
 329           (group-by-2 (cddr chars)
 330                       (cons (string (car chars) (cadr chars))
 331                             result))))
 332    (let ((lower-case-accented-chars
 333           (group-by-2 (string->list lower-case-accented-string) (list)))
 334          (upper-case-accented-chars
 335           (group-by-2 (string->list upper-case-accented-string) (list))))
 336      (set! string-upper-case
 337            (lambda (str)
 338              (define (replace-chars str froms tos)
 339                (if (null? froms)
 340                    str
 341                    (replace-chars (regexp-substitute/global #f (car froms) str
 342                                                             'pre (car tos) 'post)
 343                                   (cdr froms)
 344                                   (cdr tos))))
 345              (string-upcase (replace-chars str
 346                                            lower-case-accented-chars
 347                                            upper-case-accented-chars))))
 348      (set! accented-char-upper-case?
 349            (lambda (char1 char2)
 350              (member (string char1 char2) upper-case-accented-chars string=?)))
 351      (set! accented-char-lower-case?
 352            (lambda (char1 char2)
 353              (member (string char1 char2) lower-case-accented-chars string=?)))))
 354
 355 #(define-markup-command (smallCaps layout props text) (markup?)
 356   "Turn @code{text}, which should be a string, to small caps.
 357 @example
 358 \\markup \\small-caps \"Text between double quotes\"
 359 @end example"
 360   (define (string-list->markup strings lower)
 361     (let ((final-string (string-upper-case
 362                          (apply string-append (reverse strings)))))
 363       (if lower
 364           (markup #:fontsize -2 final-string)
 365           final-string)))
 366   (define (make-small-caps rest-chars currents current-is-lower prev-result)
 367     (if (null? rest-chars)
 368         (make-concat-markup (reverse! (cons (string-list->markup
 369                                               currents current-is-lower)
 370                                             prev-result)))
 371         (let* ((ch1 (car rest-chars))
 372                (ch2 (and (not (null? (cdr rest-chars))) (cadr rest-chars)))
 373                (this-char-string (string ch1))
 374                (is-lower (char-lower-case? ch1))
 375                (next-rest-chars (cdr rest-chars)))
 376           (cond ((and ch2 (accented-char-lower-case? ch1 ch2))
 377                  (set! this-char-string (string ch1 ch2))
 378                  (set! is-lower #t)
 379                  (set! next-rest-chars (cddr rest-chars)))
 380                 ((and ch2 (accented-char-upper-case? ch1 ch2))
 381                  (set! this-char-string (string ch1 ch2))
 382                  (set! is-lower #f)
 383                  (set! next-rest-chars (cddr rest-chars))))
 384           (if (or (and current-is-lower is-lower)
 385                   (and (not current-is-lower) (not is-lower)))
 386               (make-small-caps next-rest-chars
 387                                (cons this-char-string currents)
 388                                is-lower
 389                                prev-result)
 390               (make-small-caps next-rest-chars
 391                                (list this-char-string)
 392                                is-lower
 393                                (if (null? currents)
 394                                    prev-result
 395                                    (cons (string-list->markup
 396                                             currents current-is-lower)
 397                                          prev-result)))))))
 398   (interpret-markup layout props
 399     (if (string? text)
 400         (make-small-caps (string->list text) (list) #f (list))
 401         text)))
 402
 403 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 404 %%% Character lists, inline quoted scores, etc.
 405
 406 startQuote =
 407 #(define-music-function (parser location bar-num) (number?)
 408    #{ \override Score.BarNumber #'break-visibility = #'#(#f #f #t)
 409       \bar ""
 410       \set Score.currentBarNumber = #bar-num #})
 411
 412 tinyQuote = {
 413   \override Score.StaffSymbol #'staff-space = #(magstep -2)
 414   \set Score . fontSize = #-2
 415   \override Score.BarNumber #'break-visibility = #'#(#f #f #t)
 416 }
 417
 418 quoteLayout = \layout {
 419   indent = 0
 420   ragged-right = ##t
 421   \context { \Staff \remove "Time_signature_engraver" }
 422 }
 423
 424 quoteEmptyLayout = \layout {
 425   indent = 0
 426   ragged-right = ##t
 427   \context { \Score skipBars = ##t }
 428   \context {
 429     \Staff
 430     \remove "Time_signature_engraver"
 431     \remove "Clef_engraver"
 432     \remove "Staff_symbol_engraver"
 433     \override MultiMeasureRest #'expand-limit = #2
 434   }
 435 }
 436
 437 smallLayout = \layout {
 438   \context {
 439     \Staff fontSize = #-1
 440     \override StaffSymbol.staff-space = #(magstep -1)
 441   }
 442   \context { \Lyrics fontSize = #-1 }
 443   \context { \FiguredBass \override BassFigure.font-size = #-1 }
 444   \context { \Voice \override Script.avoid-slur = #'outside }
 445   \context { \CueVoice \override Script.avoid-slur = #'outside }
 446   \context {
 447     \Score
 448     \override NonMusicalPaperColumn.line-break-permission = #'allow
 449     \override NonMusicalPaperColumn.page-break-permission = #'allow
 450   }
 451 }
 452
 453 onlyNotesLayout = \layout {
 454   indent = 0
 455   \context {
 456     \Staff
 457     \remove "Time_signature_engraver"
 458     \remove "Clef_engraver"
 459     \remove "Staff_symbol_engraver"
 460   }
 461   \context { \Score \remove "Bar_number_engraver" }
 462 }
 463
 464 characterLayout = \layout {
 465   \quoteLayout
 466   line-width = #(if (eqv? #t (ly:get-option 'ancient-style))
 467                     (* 10 mm)
 468                     (* 18 mm))
 469   ragged-right = ##f
 470   \context {
 471     \Staff
 472     \override Clef #'full-size-change = ##t
 473     \remove "Bar_engraver"
 474   }
 475   \context {
 476     \Voice
 477     \remove "Stem_engraver"
 478   }
 479 }
 480
 481 characterAmbitus =
 482 #(define-music-function (parser location clef1 clef2 low-note high-note)
 483      (string? string? ly:music? ly:music?)
 484    (let* ((low-pitch (ly:music-property low-note 'pitch))
 485           (high-pitch (ly:music-property high-note 'pitch))
 486           (chord (make-music
 487                   'EventChord
 488                   'elements (list (make-music
 489                                    'NoteEvent
 490                                    'duration (ly:make-duration 2 0 1 1)
 491                                    'pitch low-pitch)
 492                                   (make-music
 493                                    'NoteEvent
 494                                    'duration (ly:make-duration 2 0 1 1)
 495                                    'pitch high-pitch)))))
 496      (if (eqv? #t (ly:get-option 'ancient-style))
 497          #{ \new Staff { \clef $clef1 $chord } #}
 498          #{ \new Staff {
 499   \clef $clef1 s16
 500   \set Staff.forceClef = ##t
 501   \clef $clef2 s8. $chord s2
 502 } #})))
 503
 504
 505 #(define-markup-command (character-ambitus layout props name ambitus)
 506      (markup? markup?)
 507    #:properties ((character-width-ratio 16/20)
 508                  (ambitus-width-ratio 3/20))
 509    (stack-lines
 510     DOWN 0 0
 511     (list empty-stencil
 512           (interpret-markup layout props
 513                             (markup
 514                              #:force-line-width-ratio ambitus-width-ratio
 515                              #:vcenter #:fill-line (#:null #:left-align ambitus)
 516                              #:hspace 2
 517                              #:force-line-width-ratio character-width-ratio
 518                              #:vcenter #:smallCaps name)))))
 519
 520 #(define-markup-command (character-two-columns layout props col1 col2)
 521      (markup? markup?)
 522    #:properties ((word-space 0.6)
 523                  (character-width-ratio 10/30)
 524                  (ambitus-width-ratio 4/30))
 525    (interpret-markup
 526     layout props
 527     #{ \markup
 528        \override #`(character-width-ratio . ,character-width-ratio)
 529        \override #`(ambitus-width-ratio . ,ambitus-width-ratio)
 530        \fill-line {
 531          \null
 532          \override #`(word-space . ,word-space) $col1
 533          \hspace #3
 534          \override #`(word-space . ,word-space) $col2
 535          \null
 536        } #}))
 537
 538 #(define-markup-command (character-three-columns layout props col1 col2 col3)
 539      (markup? markup? markup?)
 540    #:properties ((word-space 0.6))
 541    (interpret-markup
 542     layout props
 543     (markup (#:concat (#:override `(word-space . ,word-space) col1
 544                                   #:hspace 3
 545                                   #:override `(word-space . ,word-space) col2
 546                                   #:hspace 3
 547                                   #:override `(word-space . ,word-space) col3)))))
 548
 549 #(define-markup-command (sline layout props args) (markup-list?)
 550    (interpret-markup layout props
 551                      (make-line-markup (cons (make-hspace-markup 4) args))))
 552
 553 %% Verse margins
 554 #(define-markup-command (verse layout props syllab-count words)
 555      (number? markup-list?)
 556    (interpret-markup
 557     layout props
 558     (if (< syllab-count 12)
 559         (make-line-markup (cons (make-hspace-markup (* 1.5 (- 12 syllab-count)))
 560                                 words))
 561         (make-line-markup words))))
 562
 563
 564 %%% Foot notes
 565 \paper {
 566   footnote-auto-numbering = ##t
 567   footnote-numbering-function =
 568   #(lambda (num)
 569      (markup #:small #:box (number->string (+ 1 num))))
 570   footnote-separator-markup = \markup\override #'(span-factor . 1/4) \draw-hline
 571   footnote-padding = 2\mm
 572   footnote-footer-padding = 1\mm
 573 }
 574
 575 footnoteHere =
 576 #(define-music-function (parser location offset note)
 577      (number-pair? markup?)
 578    (let ((foot-mus (make-music
 579                     'FootnoteEvent
 580                     'X-offset (car offset)
 581                     'Y-offset (+ 0.5 (cdr offset))
 582                     'automatically-numbered #t
 583                     'text (make-null-markup)
 584                     'footnote-text note)))
 585      #{ <>-\tweak footnote-music #foot-mus ^\markup " " #}))