scm/translation-functions.scm

   1 ;;;; translation-functions.scm --
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 1998--2009 Han-Wen Nienhuys <hanwen@xs4all.nl>
   6 ;;;;                 Jan Nieuwenhuizen <janneke@gnu.org>
   7
   8
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10 ;; metronome marks
  11
  12 (define-public (format-metronome-markup text dur count context)
  13   (let* ((hide-note (eq? #t (ly:context-property context 'tempoHideNote))))
  14     (metronome-markup text dur count hide-note)))
  15
  16 (define-public (metronome-markup text dur count hide-note)
  17   (let* ((note-mark (if (and (not hide-note) (ly:duration? dur))
  18                         (make-smaller-markup
  19                          (make-note-by-number-markup (ly:duration-log dur)
  20                                                      (ly:duration-dot-count dur)
  21                                                      1))
  22                         #f))
  23          (note-markup (if (and (not hide-note) (number? count) (> count 0) )
  24                           (make-concat-markup
  25                            (list
  26                             (make-general-align-markup Y DOWN note-mark)
  27                             (make-simple-markup " ")
  28                             (make-simple-markup "=")
  29                             (make-simple-markup " ")
  30                             (make-simple-markup (number->string count))))
  31                           #f))
  32          (text-markup (if (not (null? text))
  33                           (make-bold-markup text)
  34                           #f)))
  35     (if text-markup
  36         (if (and note-markup (not hide-note))
  37             (make-line-markup (list text-markup
  38                                     (make-concat-markup
  39                                      (list (make-simple-markup "(")
  40                                            note-markup
  41                                            (make-simple-markup ")")))))
  42             (make-line-markup (list text-markup)))
  43         (if note-markup
  44             (make-line-markup (list note-markup))
  45             (make-null-markup)))))
  46
  47 (define-public (format-mark-alphabet mark context)
  48   (make-bold-markup (make-markalphabet-markup (1- mark))))
  49
  50 (define-public (format-mark-box-alphabet mark context)
  51   (make-bold-markup (make-box-markup (make-markalphabet-markup (1- mark)))))
  52
  53 (define-public (format-mark-circle-alphabet mark context)
  54   (make-bold-markup (make-circle-markup (make-markalphabet-markup (1- mark)))))
  55
  56 (define-public (format-mark-letters mark context)
  57   (make-bold-markup (make-markletter-markup (1- mark))))
  58
  59 (define-public (format-mark-numbers mark context)
  60   (make-bold-markup (number->string mark)))
  61
  62 (define-public (format-mark-barnumbers mark context)
  63   (make-bold-markup (number->string (ly:context-property context
  64                                                          'currentBarNumber))))
  65
  66 (define-public (format-mark-box-letters mark context)
  67   (make-bold-markup (make-box-markup (make-markletter-markup (1- mark)))))
  68
  69 (define-public (format-mark-circle-letters mark context)
  70   (make-bold-markup (make-circle-markup (make-markletter-markup (1- mark)))))
  71
  72 (define-public (format-mark-box-numbers mark context)
  73   (make-bold-markup (make-box-markup (number->string mark))))
  74
  75 (define-public (format-mark-circle-numbers mark context)
  76   (make-bold-markup (make-circle-markup (number->string mark))))
  77
  78 (define-public (format-mark-box-barnumbers mark context)
  79   (make-bold-markup (make-box-markup
  80                      (number->string (ly:context-property context
  81                                                           'currentBarNumber)))))
  82
  83 (define-public (format-mark-circle-barnumbers mark context)
  84   (make-bold-markup (make-circle-markup
  85                      (number->string (ly:context-property context
  86                                                           'currentBarNumber)))))
  87
  88
  89 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  90 ;; Bass figures.
  91
  92 (define-public (format-bass-figure figure event context)
  93   (let* ((fig (ly:event-property event 'figure))
  94          (fig-markup (if (number? figure)
  95
  96                          ;; this is not very elegant, but center-aligning
  97                          ;; all digits is problematic with other markups,
  98                          ;; and shows problems in the (lack of) overshoot
  99                          ;; of feta-alphabet glyphs.
 100                          ((if (<= 10 figure)
 101                               (lambda (y) (make-translate-scaled-markup
 102                                            (cons -0.7 0) y))
 103                               identity)
 104
 105                           (cond
 106                            ((eq? #t (ly:event-property event 'diminished))
 107                             (markup #:slashed-digit figure))
 108                            ((eq? #t (ly:event-property event 'augmented-slash))
 109                             (markup #:backslashed-digit figure))
 110                            (else (markup #:number (number->string figure 10)))))
 111                          #f))
 112
 113          (alt (ly:event-property event 'alteration))
 114          (alt-markup
 115           (if (number? alt)
 116               (markup
 117                #:general-align Y DOWN #:fontsize
 118                (if (not (= alt DOUBLE-SHARP))
 119                    -2 2)
 120                (alteration->text-accidental-markup alt))
 121               #f))
 122
 123          (plus-markup (if (eq? #t (ly:event-property event 'augmented))
 124                           (markup #:number "+")
 125                           #f))
 126
 127          (alt-dir (ly:context-property context 'figuredBassAlterationDirection))
 128          (plus-dir (ly:context-property context 'figuredBassPlusDirection)))
 129
 130     (if (and (not fig-markup) alt-markup)
 131         (begin
 132           (set! fig-markup (markup #:left-align #:pad-around 0.3 alt-markup))
 133           (set! alt-markup #f)))
 134
 135
 136     ;; hmm, how to get figures centered between note, and
 137     ;; lone accidentals too?
 138
 139     ;;    (if (markup? fig-markup)
 140     ;;  (set!
 141     ;;   fig-markup (markup #:translate (cons 1.0 0)
 142     ;;                      #:center-align fig-markup)))
 143
 144     (if alt-markup
 145         (set! fig-markup
 146               (markup #:put-adjacent
 147                       X (if (number? alt-dir)
 148                             alt-dir
 149                             LEFT)
 150                       fig-markup
 151                       #:pad-x 0.2 alt-markup)))
 152
 153     (if plus-markup
 154         (set! fig-markup
 155               (if fig-markup
 156                   (markup #:put-adjacent
 157                           X (if (number? plus-dir)
 158                                 plus-dir
 159                                 LEFT)
 160                           fig-markup
 161                           #:pad-x 0.2 plus-markup)
 162                   plus-markup)))
 163
 164     (if (markup? fig-markup)
 165         (markup #:fontsize -2 fig-markup)
 166         empty-markup)))
 167
 168
 169 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 170 ;; fret diagrams
 171
 172 (define-public (determine-frets context grob notes string-numbers)
 173
 174   (define (ensure-number a b)
 175     (if (number? a)
 176         a
 177         b))
 178
 179   (define (string-frets->dot-placement string-frets string-count)
 180     (let* ((desc (list->vector
 181                   (map (lambda (x) (list 'mute  (1+ x)))
 182                        (iota string-count)))))
 183
 184       (for-each (lambda (sf)
 185                   (let* ((string (car sf))
 186                          (fret (cadr sf))
 187                          (finger (caddr sf)))
 188
 189                     (vector-set!
 190                      desc (1- string)
 191                      (if (= 0 fret)
 192                          (list 'open string)
 193                          (if finger
 194                              (list 'place-fret string fret finger)
 195                              (list 'place-fret string fret))))))
 196                 string-frets)
 197
 198       (vector->list desc)))
 199
 200   (define (get-predefined-fretboard predefined-fret-table tuning pitches)
 201 ;   (_i "Search through @var{predefined-fret-table} looking for a predefined
 202 ;fretboard with a key of @var{(tuning . pitches)}.  The search will check
 203 ;both up and down an octave in order to accomodate transposition of the
 204 ;chords.")
 205     (define (get-fretboard key)
 206       (let ((hash-handle
 207              (hash-get-handle predefined-fret-table key)))
 208         (if hash-handle
 209             (cdr hash-handle)  ; return table entry
 210             '())))
 211
 212     (let ((test-fretboard (get-fretboard (cons tuning pitches))))
 213       (if (not (null? test-fretboard))
 214           test-fretboard
 215           (let ((test-fretboard
 216                  (get-fretboard
 217                   (cons tuning (map (lambda (x) (shift-octave x 1)) pitches)))))
 218             (if (not (null? test-fretboard))
 219                 test-fretboard
 220                 (get-fretboard
 221                  (cons tuning (map (lambda (x) (shift-octave x -1))
 222                                    pitches))))))))
 223
 224 ;; body.
 225   (let* ((tunings (ly:context-property context 'stringTunings))
 226          (my-string-count (length tunings))
 227          (details (ly:grob-property grob 'fret-diagram-details))
 228          (predefined-frets
 229           (ly:context-property context 'predefinedDiagramTable))
 230          (minimum-fret (ensure-number
 231                         (ly:context-property context 'minimumFret) 0))
 232          (max-stretch (ensure-number
 233                        (ly:context-property context 'maximumFretStretch) 4))
 234          (string-frets (determine-frets-mf notes string-numbers
 235                                            minimum-fret max-stretch
 236                                            tunings))
 237          (pitches (map (lambda (x) (ly:event-property x 'pitch)) notes)))
 238
 239     (set! (ly:grob-property grob 'fret-diagram-details)
 240
 241           (if (null? details)
 242               (acons 'string-count (length tunings) '())
 243               (acons 'string-count (length tunings) details)))
 244
 245     (set! (ly:grob-property grob 'dot-placement-list)
 246           (if predefined-frets
 247               (let ((predefined-fretboard
 248                      (get-predefined-fretboard
 249                       predefined-frets
 250                       tunings
 251                       pitches)))
 252                 (if (null? predefined-fretboard)
 253                     (string-frets->dot-placement
 254                      string-frets my-string-count)  ;no predefined diagram
 255                     predefined-fretboard)) ;found default diagram
 256               (string-frets->dot-placement string-frets my-string-count)))))
 257
 258 (define-public (determine-frets-mf notes string-numbers
 259                                    minimum-fret max-stretch
 260                                    tunings)
 261
 262   (define (calc-fret pitch string tuning)
 263     (- (ly:pitch-semitones pitch) (list-ref tuning (1- string))))
 264
 265   (define (note-pitch a)
 266     (ly:event-property a 'pitch))
 267
 268   (define (note-pitch>? a b)
 269     (ly:pitch<? (note-pitch b)
 270                 (note-pitch a)))
 271
 272   (define (note-finger ev)
 273     (let* ((articulations (ly:event-property ev 'articulations))
 274            (finger-found #f))
 275
 276       (map (lambda (art)
 277              (let* ((num (ly:event-property art 'digit)))
 278
 279                (if (and (eq? 'fingering-event (ly:event-property art 'class))
 280                         (number? num))
 281                    (set! finger-found num))))
 282            articulations)
 283
 284       finger-found))
 285
 286   (define (note-string ev)
 287     (let* ((articulations (ly:event-property ev 'articulations))
 288            (string-found #f))
 289
 290       (map (lambda (art)
 291              (let* ((num (ly:event-property art 'string-number)))
 292
 293                (if (number? num)
 294                    (set! string-found num))))
 295            articulations)
 296
 297       string-found))
 298
 299   (define (del-string string)
 300     (if (number? string)
 301         (set! free-strings
 302               (delete string free-strings))))
 303
 304   (define specified-frets '())
 305   (define free-strings '())
 306
 307   (define (close-enough fret)
 308     (reduce
 309      (lambda (x y)
 310        (and x y))
 311      #t
 312      (map (lambda (specced-fret)
 313             (> max-stretch (abs (- fret specced-fret))))
 314           specified-frets)))
 315
 316   (define (string-qualifies string pitch)
 317     (let* ((fret (calc-fret pitch string tunings)))
 318       (and (>= fret minimum-fret)
 319            (close-enough fret))))
 320
 321   (define string-fret-fingering-tuples '())
 322   (define (set-fret note string)
 323     (set! string-fret-fingering-tuples
 324           (cons (list string
 325                       (calc-fret (ly:event-property note 'pitch)
 326                                  string tunings)
 327                       (note-finger note))
 328                 string-fret-fingering-tuples))
 329     (del-string string))
 330
 331
 332   ;;; body.
 333   (set! specified-frets
 334         (filter identity (map
 335                           (lambda (note)
 336                             (if (note-string note)
 337                                 (calc-fret (note-pitch note)
 338                                            (note-string note) tunings)
 339                                 #f))
 340                           notes)))
 341
 342   (set! free-strings (map 1+ (iota (length tunings))))
 343
 344   (for-each (lambda (note)
 345               (del-string (note-string note)))
 346             notes)
 347
 348
 349   (for-each
 350    (lambda (note)
 351      (if (note-string note)
 352          (set-fret note (note-string note))
 353          (let* ((fit-string (find (lambda (string)
 354                                     (string-qualifies string (note-pitch note)))
 355                                   free-strings)))
 356            (if fit-string
 357                (set-fret note fit-string)
 358                (ly:warning "No string for pitch ~a (given frets ~a)"
 359                            (note-pitch note)
 360                            specified-frets)))))
 361    (sort notes note-pitch>?))
 362
 363   string-fret-fingering-tuples)
 364
 365
 366 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 367 ;; tablature
 368
 369 ;; The TabNoteHead tablatureFormat callback.
 370 ;; Compute the text grob-property
 371 (define-public (fret-number-tablature-format string context event)
 372   (let* ((tuning (ly:context-property context 'stringTunings))
 373          (pitch (ly:event-property event 'pitch)))
 374
 375     (make-whiteout-markup
 376      (make-vcenter-markup
 377       (format
 378        "~a"
 379        (- (ly:pitch-semitones pitch)
 380           (list-ref tuning
 381                     ;; remove 1 because list index starts at 0
 382                     ;;and guitar string at 1.
 383                     (1- string))))))))
 384
 385 ;; The 5-string banjo has got a extra string, the fifth (duh), which
 386 ;; starts at the fifth fret on the neck.  Frets on the fifth string
 387 ;; are referred to relative to the other frets:
 388 ;;   the "first fret" on the fifth string is really the sixth fret
 389 ;;   on the banjo neck.
 390 ;; We solve this by defining a new fret-number-tablature function:
 391 (define-public (fret-number-tablature-format-banjo string context event)
 392   (let* ((tuning (ly:context-property context 'stringTunings))
 393          (pitch (ly:event-property event 'pitch)))
 394
 395     (make-whiteout-markup
 396      (make-vcenter-markup
 397       (let ((fret (- (ly:pitch-semitones pitch) (list-ref tuning (1- string)))))
 398         (number->string (cond
 399                          ((and (> fret 0) (= string 5))
 400                           (+ fret 5))
 401                          (else fret))))))))
 402
 403
 404 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 405 ;; bar numbers
 406
 407 (define-public ((every-nth-bar-number-visible n) barnum)
 408   (= 0 (modulo barnum n)))
 409
 410 (define-public ((modulo-bar-number-visible n m) barnum)
 411   (and (> barnum 1) (= m (modulo barnum n))))
 412
 413 (define-public ((set-bar-number-visibility n) tr)
 414   (let ((bn (ly:context-property tr 'currentBarNumber)))
 415     (ly:context-set-property! tr 'barNumberVisibility
 416                               (modulo-bar-number-visible n (modulo bn n)))))
 417
 418 (define-public (first-bar-number-invisible barnum) (> barnum 1))
 419
 420 (define-public (all-bar-numbers-visible barnum) #t)
 421
 422
 423 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 424 ;; percent repeat counters
 425
 426 (define-public ((every-nth-repeat-count-visible n) count context)
 427   (= 0 (modulo count n)))
 428
 429 (define-public (all-repeat-counts-visible count context) #t)