scm/translation-functions.scm

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