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