]> git.donarmstrong.com Git - lilypond.git/blob - scm/translation-functions.scm
2d9d456067cc1954e8584a66a12c96cdb2b6416c
[lilypond.git] / scm / translation-functions.scm
1 ;;;; This file is part of LilyPond, the GNU music typesetter.
2 ;;;;
3 ;;;; (c) 1998--2011 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     (define specified-frets '())
280     (define free-strings (iota (length tuning) 1))
281
282     (define (calc-fret pitch string tuning)
283       "Calculate the fret to play @var{pitch} on @var{string} with
284 @var{tuning}."
285       (- (ly:pitch-semitones pitch) (ly:pitch-semitones (list-ref tuning (1- string)))))
286
287     (define (note-pitch note)
288       "Get the pitch (in semitones) from @var{note}."
289       (ly:event-property note 'pitch))
290
291     (define (note-finger ev)
292       "Get the fingering from @var{ev}.  Return @var{#f}
293 if no fingering is present."
294       (let* ((articulations (ly:event-property ev 'articulations))
295              (finger-found #f))
296         (map (lambda (art)
297                (let* ((num (ly:event-property art 'digit)))
298
299                  (if (and (eq? 'fingering-event (ly:event-property art 'class))
300                           (number? num)
301                           (> num 0))
302                    (set! finger-found num))))
303              articulations)
304         finger-found))
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         (if (number? num)
311           num
312           #f)))
313
314     (define (delete-free-string string)
315       (if (number? string)
316         (set! free-strings
317           (delete string free-strings))))
318
319     (define (close-enough fret)
320       "Decide if @var{fret} is acceptable, given the already used frets."
321       (if (null? specified-frets)
322         #t
323         (reduce
324           (lambda (x y)
325             (and x y))
326           #t
327           (map (lambda (specced-fret)
328                  (or (eq? 0 specced-fret)
329                      (>= maximum-stretch (abs (- fret specced-fret)))))
330                specified-frets))))
331
332     (define (string-qualifies string pitch)
333       "Can @var{pitch} be played on @var{string}, given already placed
334 notes?"
335       (let* ((fret (calc-fret pitch string tuning)))
336         (and (>= fret minimum-fret)
337              (close-enough fret))))
338
339     (define (open-string string pitch)
340       "Is @var{pitch} and open-string note on @var{string}, given
341 the current tuning?"
342       (let* ((fret (calc-fret pitch string tuning)))
343         (eq? fret 0)))
344
345     (define (set-fret! pitch-entry string finger)
346       (let ((this-fret (calc-fret (car pitch-entry)
347                                   string
348                                   tuning)))
349         (if (< this-fret 0)
350           (ly:warning (_ "Negative fret for pitch ~a on string ~a")
351                       (car pitch-entry) string))
352         (delete-free-string string)
353         (set! specified-frets (cons this-fret specified-frets))
354         (list-set! string-fret-fingers
355                    (cdr pitch-entry)
356                    (list string this-fret finger))))
357
358     (define string-fret-fingers
359              (map (lambda (string finger)
360                     (if (null? finger)
361                         (list string #f)
362                         (list string #f finger)))
363                   defined-strings defined-fingers))
364
365     ;;; body of determine-frets-and-strings
366     (let* ((pitch-alist (apply (lambda (mylist)
367                                  (let ((index -1))
368                                    (map (lambda (note)
369                                           (begin
370                                             (set! index (1+ index))
371                                             (cons (note-pitch note)
372                                                   index)))
373                                         mylist)))
374                                notes '()))
375            (pitches (map note-pitch notes)))
376
377       ;; handle notes with strings assigned and fingering of 0
378       (for-each
379         (lambda (pitch-entry string-fret-finger)
380           (let* ((string (list-ref string-fret-finger 0))
381                  (finger (if (eq? (length string-fret-finger) 3)
382                              (list-ref string-fret-finger 2)
383                              '()))
384                  (pitch (car pitch-entry))
385                  (digit (if (null? finger)
386                             #f
387                             finger)))
388             (if (or (not (null? string))
389                     (eq? digit 0))
390                 (if (eq? digit 0)
391                     ;; here we handle fingers of 0 -- open strings
392                     (let ((fit-string
393                             (find (lambda (string)
394                                     (open-string string pitch))
395                                   free-strings)))
396                       (if fit-string
397                           (set-fret! pitch-entry fit-string #f)
398                           (ly:warning (_ "No open string for pitch ~a")
399                                       pitch)))
400                     ;; here we handle assigned strings
401                     (let ((this-fret
402                             (calc-fret pitch string tuning))
403                           (handle-negative
404                             (ly:context-property context
405                                                  'handleNegativeFrets
406                                                  'recalculate)))
407                       (cond ((or (>= this-fret 0)
408                                  (eq? handle-negative 'include))
409                              (set-fret! pitch-entry string finger))
410                             ((eq? handle-negative 'recalculate)
411                              (begin
412                                (ly:warning
413                                  (_ "Requested string for pitch requires negative fret: string ~a pitch ~a")
414                                  string
415                                  pitch)
416                                (ly:warning (_ "Ignoring string request."))
417                                (list-set! string-fret-fingers
418                                           (cdr pitch-entry)
419                                           (if (null? finger)
420                                               (list '() #f)
421                                               (list '() #f finger)))))))))))
422         pitch-alist string-fret-fingers)
423     ;; handle notes without strings assigned -- sorted by pitch, so
424     ;; we need to use the alist to have the note number available
425     (for-each
426       (lambda (pitch-entry)
427         (let* ((string-fret-finger (list-ref string-fret-fingers
428                                              (cdr pitch-entry)))
429                (string (list-ref string-fret-finger 0))
430                (finger (if (eq? (length string-fret-finger) 3)
431                            (list-ref string-fret-finger 2)
432                            '()))
433                (pitch (car pitch-entry))
434                (fit-string
435                  (find (lambda (string)
436                          (string-qualifies string pitch))
437                        free-strings)))
438           (if (not (list-ref string-fret-finger 1))
439               (if fit-string
440                   (set-fret! pitch-entry fit-string finger)
441                   (ly:warning (_ "No string for pitch ~a (given frets ~a)")
442                               pitch
443                               specified-frets)))))
444       (sort pitch-alist (lambda (pitch-entry-a pitch-entry-b)
445                           (ly:pitch<? (car pitch-entry-b)
446                                       (car pitch-entry-a)))))
447     string-fret-fingers)) ;; end of determine-frets-and-strings
448
449   (define (get-predefined-fretboard predefined-fret-table tuning pitches)
450     "Search through @var{predefined-fret-table} looking for a predefined
451 fretboard with a key of @var{(tuning . pitches)}.  The search will check
452 both up and down an octave in order to accomodate transposition of the
453 chords.  Returns a placement-list."
454
455     (define (get-fretboard key)
456       (let ((hash-handle
457              (hash-get-handle predefined-fret-table key)))
458         (if hash-handle
459             (cdr hash-handle)  ; return table entry
460             '())))
461
462     ;; body of get-predefined-fretboard
463     (let ((test-fretboard (get-fretboard (cons tuning pitches))))
464       (if (not (null? test-fretboard))
465           test-fretboard
466           (let ((test-fretboard
467                  (get-fretboard
468                   (cons tuning (map (lambda (x) (shift-octave x 1)) pitches)))))
469             (if (not (null? test-fretboard))
470                 test-fretboard
471                 (get-fretboard
472                  (cons tuning (map (lambda (x) (shift-octave x -1))
473                                    pitches))))))))
474
475   ;; body of determine-frets
476   (let* ((predefined-fret-table
477           (ly:context-property context 'predefinedDiagramTable))
478          (tunings (ly:context-property context 'stringTunings))
479          (string-count (length tunings))
480          (grob (if (null? rest) '() (car rest)))
481          (pitches (map (lambda (x) (ly:event-property x 'pitch)) notes))
482          (defined-strings (map (lambda (x)
483                                  (if (null? x)
484                                      x
485                                      (ly:event-property x 'string-number)))
486                                (car specified-info)))
487          (defined-fingers (map (lambda (x)
488                                  (if (null? x)
489                                      x
490                                      (ly:event-property x 'digit)))
491                                (cadr specified-info)))
492          (default-strings (ly:context-property context 'defaultStrings '()))
493          (strings-used (if (and (zero? (entry-count defined-strings))
494                                 (not (zero? (entry-count default-strings))))
495                            default-strings
496                            defined-strings))
497          (predefined-fretboard
498           (if predefined-fret-table
499               (get-predefined-fretboard
500                predefined-fret-table
501                tunings
502                pitches)
503               '())))
504      (if (null? predefined-fretboard)
505          (let ((string-frets
506                 (determine-frets-and-strings
507                  notes
508                  strings-used
509                  defined-fingers
510                  (ly:context-property context 'minimumFret 0)
511                  (ly:context-property context 'maximumFretStretch 4)
512                  tunings)))
513             (if (null? grob)
514                 string-frets
515                 (create-fretboard
516                  context grob (string-frets->placement-list
517                                 string-frets string-count))))
518          (if (null? grob)
519              (placement-list->string-frets predefined-fretboard)
520              (create-fretboard context grob predefined-fretboard)))))
521
522
523
524 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
525 ;; tablature
526
527 ;; The TabNoteHead tablatureFormat callbacks.
528
529 ;; Calculate the fret from pitch and string number as letter
530 ;; The fret letter is taken from 'fretLabels if present
531 (define-public (fret-letter-tablature-format
532                 context string-number fret-number)
533  (let ((labels (ly:context-property context 'fretLabels)))
534   (make-vcenter-markup
535    (cond
536     ((= 0 (length labels))
537      (string (integer->char (+ fret-number (char->integer #\a)))))
538     ((and (<= 0 fret-number) (< fret-number (length labels)))
539      (list-ref labels fret-number))
540     (else
541      (ly:warning (_ "No label for fret ~a (on string ~a);
542 only ~a fret labels provided")
543                 fret-number string-number (length labels))
544      ".")))))
545
546 ;; Display the fret number as a number
547 (define-public (fret-number-tablature-format
548                 context string-number fret-number)
549   (make-vcenter-markup
550     (format "~a" fret-number)))
551
552 ;; The 5-string banjo has got a extra string, the fifth (duh), which
553 ;; starts at the fifth fret on the neck.  Frets on the fifth string
554 ;; are referred to relative to the other frets:
555 ;;   the "first fret" on the fifth string is really the sixth fret
556 ;;   on the banjo neck.
557 ;; We solve this by defining a new fret-number-tablature function:
558 (define-public (fret-number-tablature-format-banjo
559                 context string-number fret-number)
560  (make-vcenter-markup
561   (number->string (cond
562                    ((and (> fret-number 0) (= string-number 5))
563                     (+ fret-number 5))
564                    (else fret-number)))))
565
566 ;;  Tab note head staff position functions
567 ;;
568 ;;  Define where in the staff to display a given string.  Some forms of
569 ;;  tablature put the tab note heads in the spaces, rather than on the
570 ;;  lines
571
572 (define-public (tablature-position-on-lines context string-number)
573  (let* ((string-tunings (ly:context-property context 'stringTunings))
574         (string-count (length string-tunings))
575         (string-one-topmost (ly:context-property context 'stringOneTopmost))
576         (staff-line (- (* 2 string-number) string-count 1)))
577   (if string-one-topmost
578       (- staff-line)
579       staff-line)))
580
581 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
582 ;; bar numbers
583
584 (define-public ((every-nth-bar-number-visible n) barnum)
585   (= 0 (modulo barnum n)))
586
587 (define-public ((modulo-bar-number-visible n m) barnum)
588   (and (> barnum 1) (= m (modulo barnum n))))
589
590 (define-public ((set-bar-number-visibility n) tr)
591   (let ((bn (ly:context-property tr 'currentBarNumber)))
592     (ly:context-set-property! tr 'barNumberVisibility
593                               (modulo-bar-number-visible n (modulo bn n)))))
594
595 (define-public (first-bar-number-invisible barnum) (> barnum 1))
596
597 (define-public (all-bar-numbers-visible barnum) #t)
598
599
600 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
601 ;; percent repeat counters
602
603 (define-public ((every-nth-repeat-count-visible n) count context)
604   (= 0 (modulo count n)))
605
606 (define-public (all-repeat-counts-visible count context) #t)