scm/translation-functions.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; (c) 1998--2014 Han-Wen Nienhuys <hanwen@xs4all.nl>
   4 ;;;;                 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;;;
   6 ;;;; LilyPond is free software: you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation, either version 3 of the License, or
   9 ;;;; (at your option) any later version.
  10 ;;;;
  11 ;;;; LilyPond is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  18
  19
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21 ;; clefs
  22
  23 (define-public (clef-transposition-markup oct style)
  24   "The transposition sign formatting function.  @var{oct} is supposed to be
  25 a string holding the transposition number, @var{style} determines the
  26 way the transposition number is displayed."
  27   (let* ((delim (if (symbol? style)
  28                     (case style
  29                       ((parenthesized) (cons "(" ")"))
  30                       ((bracketed) (cons "[" "]"))
  31                       (else (cons "" "")))
  32                     (cons "" "")))
  33          (text (string-concatenate (list (car delim) oct (cdr delim)))))
  34
  35     (make-vcenter-markup text)))
  36
  37
  38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  39 ;; metronome marks
  40
  41 ;; We give 'styled-metronome-markup' an optional argument, 'glyph-font', to
  42 ;; prepare using other fonts than 'fetaMusic.
  43 ;; Currently it ensures that the default-fonts are used by the
  44 ;; markup-command 'note-by-number' in 'metronome-markup' (see below).
  45 (define*
  46   ((styled-metronome-markup #:optional (glyph-font 'default))
  47                             event context)
  48    (let ((hide-note (ly:context-property context 'tempoHideNote #f))
  49          (text (ly:event-property event 'text))
  50          (dur (ly:event-property event 'tempo-unit))
  51          (count (ly:event-property event 'metronome-count)))
  52
  53    (metronome-markup glyph-font text dur count hide-note)))
  54 (export styled-metronome-markup)
  55
  56 (define-public format-metronome-markup
  57   (styled-metronome-markup))
  58
  59 (define (metronome-markup glyph-font text dur count hide-note)
  60   (let* ((note-mark
  61             (if (and (not hide-note) (ly:duration? dur))
  62                 (make-smaller-markup
  63                    ;; We insert the (default)-font for flag-glyphs and
  64                    ;; note-head-glyphs to prepare the possibility to use
  65                    ;; other fonts and to make possible using
  66                    ;; \override MetronomeMark #'font-name = #<font-name>
  67                    ;; without affecting the note/flag-glyphs.
  68                    (make-override-markup (cons 'font-name glyph-font)
  69                     (make-note-by-number-markup
  70                         (ly:duration-log dur)
  71                         (ly:duration-dot-count dur)
  72                         UP)))
  73                       #f))
  74          (count-markup (cond ((number? count)
  75                               (if (> count 0)
  76                                   (make-simple-markup
  77                                           (number->string count))
  78                                   #f))
  79                              ((pair? count)
  80                               (make-concat-markup
  81                                (list
  82                                 (make-simple-markup
  83                                         (number->string (car count)))
  84                                 (make-simple-markup " ")
  85                                 (make-simple-markup "–")
  86                                 (make-simple-markup " ")
  87                                 (make-simple-markup
  88                                         (number->string (cdr count))))))
  89                              (else #f)))
  90          (note-markup (if (and (not hide-note) count-markup)
  91                           (make-concat-markup
  92                            (list
  93                             (make-general-align-markup Y DOWN note-mark)
  94                             (make-simple-markup " ")
  95                             (make-simple-markup "=")
  96                             (make-simple-markup " ")
  97                             count-markup))
  98                           #f))
  99          (text-markup (if (not (null? text))
 100                           (make-bold-markup text)
 101                           #f)))
 102     (if text-markup
 103         (if (and note-markup (not hide-note))
 104             (make-line-markup (list text-markup
 105                                     (make-concat-markup
 106                                      (list (make-simple-markup "(")
 107                                            note-markup
 108                                            (make-simple-markup ")")))))
 109             (make-line-markup (list text-markup)))
 110         (if note-markup
 111             (make-line-markup (list note-markup))
 112             (make-null-markup)))))
 113
 114 (define-public (format-mark-alphabet mark context)
 115   (make-bold-markup (make-markalphabet-markup (1- mark))))
 116
 117 (define-public (format-mark-box-alphabet mark context)
 118   (make-bold-markup (make-box-markup (make-markalphabet-markup (1- mark)))))
 119
 120 (define-public (format-mark-circle-alphabet mark context)
 121   (make-bold-markup (make-circle-markup (make-markalphabet-markup (1- mark)))))
 122
 123 (define-public (format-mark-letters mark context)
 124   (make-bold-markup (make-markletter-markup (1- mark))))
 125
 126 (define-public (format-mark-numbers mark context)
 127   (make-bold-markup (number->string mark)))
 128
 129 (define-public (format-mark-barnumbers mark context)
 130   (make-bold-markup (number->string (ly:context-property context
 131                                                          'currentBarNumber))))
 132
 133 (define-public (format-mark-box-letters mark context)
 134   (make-bold-markup (make-box-markup (make-markletter-markup (1- mark)))))
 135
 136 (define-public (format-mark-circle-letters mark context)
 137   (make-bold-markup (make-circle-markup (make-markletter-markup (1- mark)))))
 138
 139 (define-public (format-mark-box-numbers mark context)
 140   (make-bold-markup (make-box-markup (number->string mark))))
 141
 142 (define-public (format-mark-circle-numbers mark context)
 143   (make-bold-markup (make-circle-markup (number->string mark))))
 144
 145 (define-public (format-mark-box-barnumbers mark context)
 146   (make-bold-markup (make-box-markup
 147                      (number->string (ly:context-property context
 148                                                           'currentBarNumber)))))
 149
 150 (define-public (format-mark-circle-barnumbers mark context)
 151   (make-bold-markup (make-circle-markup
 152                      (number->string (ly:context-property context
 153                                                           'currentBarNumber)))))
 154
 155
 156 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 157 ;; Bass figures.
 158
 159 (define-public (format-bass-figure figure event context)
 160   (let* ((fig (ly:event-property event 'figure))
 161          (fig-markup (if (number? figure)
 162
 163                          ;; this is not very elegant, but center-aligning
 164                          ;; all digits is problematic with other markups,
 165                          ;; and shows problems in the (lack of) overshoot
 166                          ;; of feta-alphabet glyphs.
 167                          ((if (<= 10 figure)
 168                               (lambda (y) (make-translate-scaled-markup
 169                                            (cons -0.7 0) y))
 170                               identity)
 171
 172                           (cond
 173                            ((eq? #t (ly:event-property event 'diminished))
 174                             (markup #:slashed-digit figure))
 175                            ((eq? #t (ly:event-property event 'augmented-slash))
 176                             (markup #:backslashed-digit figure))
 177                            (else (markup #:number (number->string figure 10)))))
 178                          #f))
 179
 180          (alt (ly:event-property event 'alteration))
 181          (alt-markup
 182           (if (number? alt)
 183               (markup
 184                #:general-align Y DOWN #:fontsize
 185                (if (not (= alt DOUBLE-SHARP))
 186                    -2 2)
 187                (alteration->text-accidental-markup alt))
 188               #f))
 189
 190          (plus-markup (if (eq? #t (ly:event-property event 'augmented))
 191                           (markup #:number "+")
 192                           #f))
 193
 194          (alt-dir (ly:context-property context 'figuredBassAlterationDirection))
 195          (plus-dir (ly:context-property context 'figuredBassPlusDirection)))
 196
 197     (if (and (not fig-markup) alt-markup)
 198         (begin
 199           (set! fig-markup (markup #:left-align #:pad-around 0.3 alt-markup))
 200           (set! alt-markup #f)))
 201
 202
 203     ;; hmm, how to get figures centered between note, and
 204     ;; lone accidentals too?
 205
 206     ;;    (if (markup? fig-markup)
 207     ;;  (set!
 208     ;;   fig-markup (markup #:translate (cons 1.0 0)
 209     ;;                      #:center-align fig-markup)))
 210
 211     (if alt-markup
 212         (set! fig-markup
 213               (markup #:put-adjacent
 214                       X (if (number? alt-dir)
 215                             alt-dir
 216                             LEFT)
 217                       fig-markup
 218                       #:pad-x 0.2 alt-markup)))
 219
 220     (if plus-markup
 221         (set! fig-markup
 222               (if fig-markup
 223                   (markup #:put-adjacent
 224                           X (if (number? plus-dir)
 225                                 plus-dir
 226                                 LEFT)
 227                           fig-markup
 228                           #:pad-x 0.2 plus-markup)
 229                   plus-markup)))
 230
 231     (if (markup? fig-markup)
 232         (markup #:fontsize -2 fig-markup)
 233         empty-markup)))
 234
 235
 236 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 237 ;; fret diagrams
 238
 239 (define (create-fretboard context grob placement-list)
 240   "Convert @var{placement-list} into a fretboard @var{grob}."
 241
 242   (let* ((tunings (ly:context-property context 'stringTunings))
 243          (my-string-count (length tunings))
 244          (details (ly:grob-property grob 'fret-diagram-details)))
 245
 246     ;; Add string-count from string-tunings to fret-diagram-details.
 247     (set! (ly:grob-property grob 'fret-diagram-details)
 248           (acons 'string-count my-string-count details))
 249     ;; Create the dot-placement list for the grob
 250     (set! (ly:grob-property grob 'dot-placement-list) placement-list)))
 251
 252 (define-public
 253   (determine-frets context notes specified-info . rest)
 254   "Determine string numbers and frets for playing @var{notes}
 255 as a chord, given specified information @var{specified-info}.
 256 @var{specified-info} is a list with two list elements,
 257 specified strings @code{defined-strings} and
 258 specified fingerings @code{defined-fingers}.  Only a fingering of@tie{}0
 259 will affect the fret selection, as it specifies an open string.
 260 If @code{defined-strings} is @code{'()}, the context property
 261 @code{defaultStrings} will be used as a list of defined strings.
 262 Will look for predefined fretboards if @code{predefinedFretboardTable}
 263 is not @code {#f}.  If @var{rest} is present, it contains the
 264 @code{FretBoard} grob, and a fretboard will be
 265 created.  Otherwise, a list of @code{(string fret finger)} lists will
 266 be returned."
 267
 268   ;;  helper functions
 269
 270   (define (string-frets->placement-list string-frets string-count)
 271     "Convert @var{string-frets} to @code{fret-diagram-verbose}
 272 dot placement entries."
 273     (let* ((placements (list->vector
 274                         (map (lambda (x) (list 'mute  x))
 275                              (iota string-count 1)))))
 276
 277       (for-each (lambda (sf)
 278                   (let* ((string (car sf))
 279                          (fret (cadr sf))
 280                          (finger (caddr sf)))
 281                     (vector-set!
 282                      placements
 283                      (1- string)
 284                      (if (= 0 fret)
 285                          (list 'open string)
 286                          (if finger
 287                              (list 'place-fret string fret finger)
 288                              (list 'place-fret string fret))))))
 289                 string-frets)
 290       (vector->list placements)))
 291
 292   (define (placement-list->string-frets placement-list)
 293     "Convert @var{placement-list} to string-fret list."
 294     (map (lambda (x) (if (eq? (car x) 'place-fret)
 295                          (cdr x)
 296                          (list (cadr x) 0)))
 297          (filter (lambda (l) (or (eq? (car l) 'place-fret)
 298                                  (eq? (car l) 'open)))
 299                  placement-list)))
 300
 301   (define (entry-count art-list)
 302     "Count the number of entries in a list of articulations."
 303     (length (filter (lambda (x) (not (null? x)))
 304                     art-list)))
 305
 306   (define (string-number event)
 307     "Get the string-number from @var{event}.  Return @var{#f}
 308 if no string-number is present."
 309     (let ((num (ly:event-property event 'string-number)))
 310       (and (integer? num) (positive? num) num)))
 311
 312   (define (determine-frets-and-strings
 313            notes
 314            defined-strings
 315            defined-fingers
 316            minimum-fret
 317            maximum-stretch
 318            tuning)
 319     "Determine the frets and strings used to play the notes in
 320 @var{notes}, given @var{defined-strings} and @var{defined-fingers}
 321 along with @var{minimum-fret}, @var{maximum-stretch}, and
 322 @var{tuning}.  Returns a list of @code{(string fret finger) lists."
 323
 324
 325     (define restrain-open-strings (ly:context-property context
 326                                                        'restrainOpenStrings
 327                                                        #f))
 328     (define specified-frets '())
 329     (define free-strings (iota (length tuning) 1))
 330
 331     (define (calc-fret pitch string tuning)
 332       "Calculate the fret to play @var{pitch} on @var{string} with
 333 @var{tuning}."
 334       (* 2  (- (ly:pitch-tones pitch) (ly:pitch-tones (list-ref tuning (1- string))))))
 335
 336     (define (note-pitch note)
 337       "Get the pitch (in semitones) from @var{note}."
 338       (ly:event-property note 'pitch))
 339
 340     (define (note-finger ev)
 341       "Get the fingering from @var{ev}.  Return @var{#f}
 342 if no fingering is present."
 343       (let* ((articulations (ly:event-property ev 'articulations))
 344              (finger-found #f))
 345         (for-each (lambda (art)
 346                     (let* ((num (ly:event-property art 'digit)))
 347
 348                       (if (and (ly:in-event-class? art 'fingering-event)
 349                                (number? num)
 350                                (> num 0))
 351                           (set! finger-found num))))
 352                   articulations)
 353         finger-found))
 354
 355     (define (delete-free-string string)
 356       (if (number? string)
 357           (set! free-strings
 358                 (delete string free-strings))))
 359
 360     (define (close-enough fret)
 361       "Decide if @var{fret} is acceptable, given the already used frets."
 362       (every (lambda (specced-fret)
 363                (or (zero? specced-fret)
 364                    (zero? fret)
 365                    (>= maximum-stretch (abs (- fret specced-fret)))))
 366              specified-frets))
 367
 368     (define (string-qualifies string pitch)
 369       "Can @var{pitch} be played on @var{string}, given already placed
 370 notes?"
 371       (let* ((fret (calc-fret pitch string tuning)))
 372         (and (or (and (not restrain-open-strings)
 373                       (zero? fret))
 374                  (>= fret minimum-fret))
 375              (integer? fret)
 376              (close-enough fret))))
 377
 378     (define (open-string string pitch)
 379       "Is @var{pitch} and open-string note on @var{string}, given
 380 the current tuning?"
 381       (let* ((fret (calc-fret pitch string tuning)))
 382         (zero? fret)))
 383
 384     (define (set-fret! pitch-entry string finger)
 385       (let ((this-fret (calc-fret (car pitch-entry)
 386                                   string
 387                                   tuning)))
 388         (if (< this-fret 0)
 389             (ly:warning (_ "Negative fret for pitch ~a on string ~a")
 390                         (car pitch-entry) string)
 391             (if (not (integer? this-fret))
 392                 (ly:warning (_ "Missing fret for pitch ~a on string ~a")
 393                             (car pitch-entry) string)))
 394         (delete-free-string string)
 395         (set! specified-frets (cons this-fret specified-frets))
 396         (list-set! string-fret-fingers
 397                    (cdr pitch-entry)
 398                    (list string this-fret finger))))
 399
 400     (define (kill-note! string-fret-fingers note-index)
 401       (list-set! string-fret-fingers note-index (list #f #t)))
 402
 403     (define string-fret-fingers
 404       (map (lambda (string finger)
 405              (if (null? finger)
 406                  (list string #f)
 407                  (list string #f finger)))
 408            defined-strings defined-fingers))
 409
 410     ;;; body of determine-frets-and-strings
 411     (let* ((pitches (map note-pitch notes))
 412            (pitch-alist (map cons pitches (iota (length pitches)))))
 413
 414       ;; handle notes with strings assigned and fingering of 0
 415       (for-each
 416        (lambda (pitch-entry string-fret-finger)
 417          (let* ((string (list-ref string-fret-finger 0))
 418                 (finger (if (= (length string-fret-finger) 3)
 419                             (list-ref string-fret-finger 2)
 420                             '()))
 421                 (pitch (car pitch-entry))
 422                 (digit (if (null? finger)
 423                            #f
 424                            finger)))
 425            (if (or (not (null? string))
 426                    (eqv? digit 0))
 427                (if (eqv? digit 0)
 428                    ;; here we handle fingers of 0 -- open strings
 429                    (let ((fit-string
 430                           (find (lambda (string)
 431                                   (open-string string pitch))
 432                                 free-strings)))
 433                      (if fit-string
 434                          (set-fret! pitch-entry fit-string #f)
 435                          (ly:warning (_ "No open string for pitch ~a")
 436                                      pitch)))
 437                    ;; here we handle assigned strings
 438                    (let ((this-fret
 439                           (calc-fret pitch string tuning))
 440                          (handle-negative
 441                           (ly:context-property context
 442                                                'handleNegativeFrets
 443                                                'recalculate)))
 444                      (cond ((or (and (>= this-fret 0) (integer? this-fret))
 445                                 (eq? handle-negative 'include))
 446                             (set-fret! pitch-entry string finger))
 447                            ((eq? handle-negative 'recalculate)
 448                             (begin
 449                               (ly:warning
 450                                (_ "Requested string for pitch requires negative fret: string ~a pitch ~a")
 451                                string
 452                                pitch)
 453                               (ly:warning (_ "Ignoring string request and recalculating."))
 454                               (list-set! string-fret-fingers
 455                                          (cdr pitch-entry)
 456                                          (if (null? finger)
 457                                              (list '() #f)
 458                                              (list '() #f finger)))))
 459                            ((eq? handle-negative 'ignore)
 460                             (begin
 461                               (ly:warning
 462                                (_ "Requested string for pitch requires negative fret: string ~a pitch ~a")
 463                                string
 464                                pitch)
 465                               (ly:warning (_ "Ignoring note in tablature."))
 466                               (kill-note! string-fret-fingers
 467                                           (cdr pitch-entry))))))))))
 468        pitch-alist string-fret-fingers)
 469       ;; handle notes without strings assigned -- sorted by pitch, so
 470       ;; we need to use the alist to have the note number available
 471       (for-each
 472        (lambda (pitch-entry)
 473          (let* ((string-fret-finger (list-ref string-fret-fingers
 474                                               (cdr pitch-entry)))
 475                 (string (list-ref string-fret-finger 0))
 476                 (finger (if (= (length string-fret-finger) 3)
 477                             (list-ref string-fret-finger 2)
 478                             '()))
 479                 (pitch (car pitch-entry))
 480                 (fit-string
 481                  (find (lambda (string)
 482                          (string-qualifies string pitch))
 483                        free-strings)))
 484            (if (not (list-ref string-fret-finger 1))
 485                (if fit-string
 486                    (set-fret! pitch-entry fit-string finger)
 487                    (begin
 488                      (ly:event-warning
 489                       (list-ref notes (cdr pitch-entry))
 490                       (_ "No string for pitch ~a (given frets ~a)")
 491                       pitch
 492                       specified-frets)
 493                      (kill-note! string-fret-fingers
 494                                  (cdr pitch-entry)))))))
 495        (sort pitch-alist (lambda (pitch-entry-a pitch-entry-b)
 496                            (ly:pitch<? (car pitch-entry-b)
 497                                        (car pitch-entry-a)))))
 498       string-fret-fingers)) ;; end of determine-frets-and-strings
 499
 500   (define (get-predefined-fretboard predefined-fret-table tuning pitches)
 501     "Search through @var{predefined-fret-table} looking for a predefined
 502 fretboard with a key of @var{(tuning . pitches)}.  The search will check
 503 both up and down an octave in order to accomodate transposition of the
 504 chords.  Returns a placement-list."
 505
 506     (define (get-fretboard key)
 507       (let ((hash-handle
 508              (hash-get-handle predefined-fret-table key)))
 509         (if hash-handle
 510             (cdr hash-handle)  ; return table entry
 511             '())))
 512
 513     ;; body of get-predefined-fretboard
 514     (let ((test-fretboard (get-fretboard (cons tuning pitches))))
 515       (if (not (null? test-fretboard))
 516           test-fretboard
 517           (let ((test-fretboard
 518                  (get-fretboard
 519                   (cons tuning (map (lambda (x) (shift-octave x 1)) pitches)))))
 520             (if (not (null? test-fretboard))
 521                 test-fretboard
 522                 (get-fretboard
 523                  (cons tuning (map (lambda (x) (shift-octave x -1))
 524                                    pitches))))))))
 525
 526   ;; body of determine-frets
 527   (let* ((predefined-fret-table
 528           (ly:context-property context 'predefinedDiagramTable))
 529          (tunings (ly:context-property context 'stringTunings))
 530          (string-count (length tunings))
 531          (grob (if (null? rest) '() (car rest)))
 532          (pitches (map (lambda (x) (ly:event-property x 'pitch)) notes))
 533          (defined-strings (map (lambda (x)
 534                                  (if (null? x)
 535                                      x
 536                                      (or (string-number x) '())))
 537                                (car specified-info)))
 538          (defined-fingers (map (lambda (x)
 539                                  (if (null? x)
 540                                      x
 541                                      (ly:event-property x 'digit)))
 542                                (cadr specified-info)))
 543          (default-strings (ly:context-property context 'defaultStrings '()))
 544          (strings-used (if (and (zero? (entry-count defined-strings))
 545                                 (not (zero? (entry-count default-strings))))
 546                            default-strings
 547                            defined-strings))
 548          (predefined-fretboard
 549           (if predefined-fret-table
 550               (get-predefined-fretboard
 551                predefined-fret-table
 552                tunings
 553                pitches)
 554               '())))
 555     (if (null? predefined-fretboard)
 556         (let ((string-frets
 557                (determine-frets-and-strings
 558                 notes
 559                 strings-used
 560                 defined-fingers
 561                 (ly:context-property context 'minimumFret 0)
 562                 (ly:context-property context 'maximumFretStretch 4)
 563                 tunings)))
 564           (if (null? grob)
 565               string-frets
 566               (create-fretboard
 567                context grob (string-frets->placement-list
 568                              (filter (lambda (entry)
 569                                        (car entry))
 570                                      string-frets)
 571                              string-count))))
 572         (if (null? grob)
 573             (placement-list->string-frets predefined-fretboard)
 574             (create-fretboard context grob predefined-fretboard)))))
 575
 576
 577
 578 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 579 ;; tablature
 580
 581 ;; The TabNoteHead tablatureFormat callbacks.
 582
 583 ;; Calculate the fret from pitch and string number as letter
 584 ;; The fret letter is taken from 'fretLabels if present
 585 (define-public (fret-letter-tablature-format
 586                 context string-number fret-number)
 587   (let ((labels (ly:context-property context 'fretLabels)))
 588     (make-vcenter-markup
 589      (cond
 590       ((= 0 (length labels))
 591        (string (integer->char (+ fret-number (char->integer #\a)))))
 592       ((and (<= 0 fret-number) (< fret-number (length labels)))
 593        (list-ref labels fret-number))
 594       (else
 595        (ly:warning (_ "No label for fret ~a (on string ~a);
 596 only ~a fret labels provided")
 597                    fret-number string-number (length labels))
 598        ".")))))
 599
 600 ;; Display the fret number as a number
 601 (define-public (fret-number-tablature-format
 602                 context string-number fret-number)
 603   (make-vcenter-markup
 604    (format #f "~a" fret-number)))
 605
 606 ;; The 5-string banjo has got an extra string, the fifth (duh), which
 607 ;; starts at the fifth fret on the neck.  Frets on the fifth string
 608 ;; are referred to relative to the other frets:
 609 ;;   the "first fret" on the fifth string is really the sixth fret
 610 ;;   on the banjo neck.
 611 ;; We solve this by defining a new fret-number-tablature function:
 612 (define-public (fret-number-tablature-format-banjo
 613                 context string-number fret-number)
 614   (make-vcenter-markup
 615    (number->string (cond
 616                     ((and (> fret-number 0) (= string-number 5))
 617                      (+ fret-number 5))
 618                     (else fret-number)))))
 619
 620 ;;  Tab note head staff position functions
 621 ;;
 622 ;;  Define where in the staff to display a given string.  Some forms of
 623 ;;  tablature put the tab note heads in the spaces, rather than on the
 624 ;;  lines
 625
 626 (define-public (tablature-position-on-lines context string-number)
 627   (let* ((string-tunings (ly:context-property context 'stringTunings))
 628          (string-count (length string-tunings))
 629          (string-one-topmost (ly:context-property context 'stringOneTopmost))
 630          (staff-line (- (* 2 string-number) string-count 1)))
 631     (if string-one-topmost
 632         (- staff-line)
 633         staff-line)))
 634
 635 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 636 ;; bar numbers
 637
 638 (define ((every-nth-bar-number-visible n) barnum mp)
 639   (= 0 (modulo barnum n)))
 640 (export every-nth-bar-number-visible)
 641
 642 (define ((modulo-bar-number-visible n m) barnum mp)
 643   (and (> barnum 1) (= m (modulo barnum n))))
 644 (export modulo-bar-number-visible)
 645
 646 (define ((set-bar-number-visibility n) tr)
 647   (let ((bn (ly:context-property tr 'currentBarNumber)))
 648     (ly:context-set-property! tr 'barNumberVisibility
 649                               (modulo-bar-number-visible n (modulo bn n)))))
 650 (export set-bar-number-visibility)
 651
 652 (define-public (first-bar-number-invisible barnum mp)
 653   (> barnum 1))
 654
 655 (define-public (first-bar-number-invisible-save-broken-bars barnum mp)
 656   (or (> barnum 1)
 657       (> (ly:moment-main-numerator mp) 0)))
 658
 659 (define-public (first-bar-number-invisible-and-no-parenthesized-bar-numbers barnum mp)
 660   (and (> barnum 1)
 661        (= (ly:moment-main-numerator mp) 0)))
 662
 663 (define-public (robust-bar-number-function barnum measure-pos alt-number context)
 664   (define (get-number-and-power an pow)
 665     (if (<= an alt-number)
 666         (get-number-and-power (+ an (expt 26 (1+ pow))) (1+ pow))
 667         (cons (+ alt-number (- (expt 26 pow) an)) (1- pow))))
 668   (define (make-letter so-far an pow)
 669     (if (< pow 0)
 670         so-far
 671         (let ((pos (modulo (quotient an (expt 26 pow)) 26)))
 672           (make-letter (string-append so-far
 673                                       (substring "abcdefghijklmnopqrstuvwxyz"
 674                                                  pos
 675                                                  (1+ pos)))
 676                        an
 677                        (1- pow)))))
 678   (let* ((number-and-power (get-number-and-power 0 0))
 679          (begin-measure (= 0 (ly:moment-main-numerator measure-pos)))
 680          (maybe-open-parenthesis (if begin-measure "" "("))
 681          (maybe-close-parenthesis (if begin-measure "" ")")))
 682     (markup (string-append maybe-open-parenthesis
 683                            (number->string barnum)
 684                            (make-letter ""
 685                                         (car number-and-power)
 686                                         (cdr number-and-power))
 687                            maybe-close-parenthesis))))
 688
 689 (define-public (all-bar-numbers-visible barnum mp) #t)
 690
 691
 692 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 693 ;; percent repeat counters
 694
 695 (define ((every-nth-repeat-count-visible n) count context)
 696   (= 0 (modulo count n)))
 697 (export every-nth-repeat-count-visible)
 698
 699 (define-public (all-repeat-counts-visible count context) #t)
 700
 701 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 702 ;; make-engraver helper macro
 703
 704 (defmacro-public make-engraver forms
 705   "Helper macro for creating Scheme engravers.
 706
 707 The usual form for an engraver is an association list (or alist)
 708 mapping symbols to either anonymous functions or to another such
 709 alist.
 710
 711 @code{make-engraver} accepts forms where the first element is either
 712 an argument list starting with the respective symbol, followed by the
 713 function body (comparable to the way @code{define} is used for
 714 defining functions), or a single symbol followed by subordinate forms
 715 in the same manner.  You can also just make an alist pair
 716 literally (the @samp{car} is quoted automatically) as long as the
 717 unevaluated @samp{cdr} is not a pair.  This is useful if you already
 718 have defined your engraver functions separately.
 719
 720 Symbols mapping to a function would be @code{initialize},
 721 @code{start-translation-timestep}, @code{process-music},
 722 @code{process-acknowledged}, @code{stop-translation-timestep}, and
 723 @code{finalize}.  Symbols mapping to another alist specified in the
 724 same manner are @code{listeners} with the subordinate symbols being
 725 event classes, and @code{acknowledgers} and @code{end-acknowledgers}
 726 with the subordinate symbols being interfaces."
 727   (let loop ((forms forms))
 728     (if (cheap-list? forms)
 729         `(list
 730           ,@(map (lambda (form)
 731                    (if (pair? (car form))
 732                        `(cons ',(caar form) (lambda ,(cdar form) ,@(cdr form)))
 733                        `(cons ',(car form) ,(loop (cdr form)))))
 734                  forms))
 735         forms)))