1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; (c) 1998--2014 Han-Wen Nienhuys <hanwen@xs4all.nl>
4 ;;;; Jan Nieuwenhuizen <janneke@gnu.org>
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.
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.
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/>.
20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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)
29 ((parenthesized) (cons "(" ")"))
30 ((bracketed) (cons "[" "]"))
33 (text (string-concatenate (list (car delim) oct (cdr delim)))))
35 (make-vcenter-markup text)))
38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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).
46 ((styled-metronome-markup #:optional (glyph-font 'default))
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)))
53 (metronome-markup glyph-font text dur count hide-note)))
54 (export styled-metronome-markup)
56 (define-public format-metronome-markup
57 (styled-metronome-markup))
59 (define (metronome-markup glyph-font text dur count hide-note)
61 (if (and (not hide-note) (ly:duration? dur))
63 ;; We insert the (default)-font for flag-glyphs and
64 ;; note-head-glyphs to prepare the possibility to use
65 ;; other fonts and to make possible using
66 ;; \override MetronomeMark #'font-name = #<font-name>
67 ;; without affecting the note/flag-glyphs.
68 (make-override-markup (cons 'font-name glyph-font)
69 (make-note-by-number-markup
71 (ly:duration-dot-count dur)
74 (count-markup (cond ((number? count)
77 (number->string count))
83 (number->string (car count)))
84 (make-simple-markup " ")
85 (make-simple-markup "–")
86 (make-simple-markup " ")
88 (number->string (cdr count))))))
90 (note-markup (if (and (not hide-note) count-markup)
93 (make-general-align-markup Y DOWN note-mark)
94 (make-simple-markup " ")
95 (make-simple-markup "=")
96 (make-simple-markup " ")
99 (text-markup (if (not (null? text))
100 (make-bold-markup text)
103 (if (and note-markup (not hide-note))
104 (make-line-markup (list text-markup
106 (list (make-simple-markup "(")
108 (make-simple-markup ")")))))
109 (make-line-markup (list text-markup)))
111 (make-line-markup (list note-markup))
112 (make-null-markup)))))
114 (define-public (format-mark-alphabet mark context)
115 (make-bold-markup (make-markalphabet-markup (1- mark))))
117 (define-public (format-mark-box-alphabet mark context)
118 (make-bold-markup (make-box-markup (make-markalphabet-markup (1- mark)))))
120 (define-public (format-mark-circle-alphabet mark context)
121 (make-bold-markup (make-circle-markup (make-markalphabet-markup (1- mark)))))
123 (define-public (format-mark-letters mark context)
124 (make-bold-markup (make-markletter-markup (1- mark))))
126 (define-public (format-mark-numbers mark context)
127 (make-bold-markup (number->string mark)))
129 (define-public (format-mark-barnumbers mark context)
130 (make-bold-markup (number->string (ly:context-property context
131 'currentBarNumber))))
133 (define-public (format-mark-box-letters mark context)
134 (make-bold-markup (make-box-markup (make-markletter-markup (1- mark)))))
136 (define-public (format-mark-circle-letters mark context)
137 (make-bold-markup (make-circle-markup (make-markletter-markup (1- mark)))))
139 (define-public (format-mark-box-numbers mark context)
140 (make-bold-markup (make-box-markup (number->string mark))))
142 (define-public (format-mark-circle-numbers mark context)
143 (make-bold-markup (make-circle-markup (number->string mark))))
145 (define-public (format-mark-box-barnumbers mark context)
146 (make-bold-markup (make-box-markup
147 (number->string (ly:context-property context
148 'currentBarNumber)))))
150 (define-public (format-mark-circle-barnumbers mark context)
151 (make-bold-markup (make-circle-markup
152 (number->string (ly:context-property context
153 'currentBarNumber)))))
156 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
159 (define-public (format-bass-figure figure event context)
160 (let* ((fig (ly:event-property event 'figure))
161 (fig-markup (if (number? figure)
163 ;; this is not very elegant, but center-aligning
164 ;; all digits is problematic with other markups,
165 ;; and shows problems in the (lack of) overshoot
166 ;; of feta-alphabet glyphs.
168 (lambda (y) (make-translate-scaled-markup
173 ((eq? #t (ly:event-property event 'diminished))
174 (markup #:slashed-digit figure))
175 ((eq? #t (ly:event-property event 'augmented-slash))
176 (markup #:backslashed-digit figure))
177 (else (markup #:number (number->string figure 10)))))
180 (alt (ly:event-property event 'alteration))
184 #:general-align Y DOWN #:fontsize
185 (if (not (= alt DOUBLE-SHARP))
187 (alteration->text-accidental-markup alt))
190 (plus-markup (if (eq? #t (ly:event-property event 'augmented))
191 (markup #:number "+")
194 (alt-dir (ly:context-property context 'figuredBassAlterationDirection))
195 (plus-dir (ly:context-property context 'figuredBassPlusDirection)))
197 (if (and (not fig-markup) alt-markup)
199 (set! fig-markup (markup #:left-align #:pad-around 0.3 alt-markup))
200 (set! alt-markup #f)))
203 ;; hmm, how to get figures centered between note, and
204 ;; lone accidentals too?
206 ;; (if (markup? fig-markup)
208 ;; fig-markup (markup #:translate (cons 1.0 0)
209 ;; #:center-align fig-markup)))
213 (markup #:put-adjacent
214 X (if (number? alt-dir)
218 #:pad-x 0.2 alt-markup)))
223 (markup #:put-adjacent
224 X (if (number? plus-dir)
228 #:pad-x 0.2 plus-markup)
231 (if (markup? fig-markup)
232 (markup #:fontsize -2 fig-markup)
236 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
239 (define (create-fretboard context grob placement-list)
240 "Convert @var{placement-list} into a fretboard @var{grob}."
242 (let* ((tunings (ly:context-property context 'stringTunings))
243 (my-string-count (length tunings))
244 (details (ly:grob-property grob 'fret-diagram-details)))
246 ;; Add string-count from string-tunings to fret-diagram-details.
247 (set! (ly:grob-property grob 'fret-diagram-details)
248 (acons 'string-count my-string-count details))
249 ;; Create the dot-placement list for the grob
250 (set! (ly:grob-property grob 'dot-placement-list) placement-list)))
253 (determine-frets context notes specified-info . rest)
254 "Determine string numbers and frets for playing @var{notes}
255 as a chord, given specified information @var{specified-info}.
256 @var{specified-info} is a list with two list elements,
257 specified strings @code{defined-strings} and
258 specified fingerings @code{defined-fingers}. Only a fingering of@tie{}0
259 will affect the fret selection, as it specifies an open string.
260 If @code{defined-strings} is @code{'()}, the context property
261 @code{defaultStrings} will be used as a list of defined strings.
262 Will look for predefined fretboards if @code{predefinedFretboardTable}
263 is not @code {#f}. If @var{rest} is present, it contains the
264 @code{FretBoard} grob, and a fretboard will be
265 created. Otherwise, a list of @code{(string fret finger)} lists will
270 (define (string-frets->placement-list string-frets string-count)
271 "Convert @var{string-frets} to @code{fret-diagram-verbose}
272 dot placement entries."
273 (let* ((placements (list->vector
274 (map (lambda (x) (list 'mute x))
275 (iota string-count 1)))))
277 (for-each (lambda (sf)
278 (let* ((string (car sf))
287 (list 'place-fret string fret finger)
288 (list 'place-fret string fret))))))
290 (vector->list placements)))
292 (define (placement-list->string-frets placement-list)
293 "Convert @var{placement-list} to string-fret list."
294 (map (lambda (x) (if (eq? (car x) 'place-fret)
297 (filter (lambda (l) (or (eq? (car l) 'place-fret)
298 (eq? (car l) 'open)))
301 (define (entry-count art-list)
302 "Count the number of entries in a list of articulations."
303 (length (filter (lambda (x) (not (null? x)))
306 (define (string-number event)
307 "Get the string-number from @var{event}. Return @var{#f}
308 if no string-number is present."
309 (let ((num (ly:event-property event 'string-number)))
310 (and (integer? num) (positive? num) num)))
312 (define (determine-frets-and-strings
319 "Determine the frets and strings used to play the notes in
320 @var{notes}, given @var{defined-strings} and @var{defined-fingers}
321 along with @var{minimum-fret}, @var{maximum-stretch}, and
322 @var{tuning}. Returns a list of @code{(string fret finger) lists."
325 (define restrain-open-strings (ly:context-property context
328 (define specified-frets '())
329 (define free-strings (iota (length tuning) 1))
331 (define (calc-fret pitch string tuning)
332 "Calculate the fret to play @var{pitch} on @var{string} with
334 (* 2 (- (ly:pitch-tones pitch) (ly:pitch-tones (list-ref tuning (1- string))))))
336 (define (note-pitch note)
337 "Get the pitch (in semitones) from @var{note}."
338 (ly:event-property note 'pitch))
340 (define (note-finger ev)
341 "Get the fingering from @var{ev}. Return @var{#f}
342 if no fingering is present."
343 (let* ((articulations (ly:event-property ev 'articulations))
345 (for-each (lambda (art)
346 (let* ((num (ly:event-property art 'digit)))
348 (if (and (ly:in-event-class? art 'fingering-event)
351 (set! finger-found num))))
355 (define (delete-free-string string)
358 (delete string free-strings))))
360 (define (close-enough fret)
361 "Decide if @var{fret} is acceptable, given the already used frets."
362 (every (lambda (specced-fret)
363 (or (zero? specced-fret)
365 (>= maximum-stretch (abs (- fret specced-fret)))))
368 (define (string-qualifies string pitch)
369 "Can @var{pitch} be played on @var{string}, given already placed
371 (let* ((fret (calc-fret pitch string tuning)))
372 (and (or (and (not restrain-open-strings)
374 (>= fret minimum-fret))
376 (close-enough fret))))
378 (define (open-string string pitch)
379 "Is @var{pitch} and open-string note on @var{string}, given
381 (let* ((fret (calc-fret pitch string tuning)))
384 (define (set-fret! pitch-entry string finger)
385 (let ((this-fret (calc-fret (car pitch-entry)
389 (ly:warning (_ "Negative fret for pitch ~a on string ~a")
390 (car pitch-entry) string)
391 (if (not (integer? this-fret))
392 (ly:warning (_ "Missing fret for pitch ~a on string ~a")
393 (car pitch-entry) string)))
394 (delete-free-string string)
395 (set! specified-frets (cons this-fret specified-frets))
396 (list-set! string-fret-fingers
398 (list string this-fret finger))))
400 (define (kill-note! string-fret-fingers note-index)
401 (list-set! string-fret-fingers note-index (list #f #t)))
403 (define string-fret-fingers
404 (map (lambda (string finger)
407 (list string #f finger)))
408 defined-strings defined-fingers))
410 ;;; body of determine-frets-and-strings
411 (let* ((pitches (map note-pitch notes))
412 (pitch-alist (map cons pitches (iota (length pitches)))))
414 ;; handle notes with strings assigned and fingering of 0
416 (lambda (pitch-entry string-fret-finger)
417 (let* ((string (list-ref string-fret-finger 0))
418 (finger (if (= (length string-fret-finger) 3)
419 (list-ref string-fret-finger 2)
421 (pitch (car pitch-entry))
422 (digit (if (null? finger)
425 (if (or (not (null? string))
428 ;; here we handle fingers of 0 -- open strings
430 (find (lambda (string)
431 (open-string string pitch))
434 (set-fret! pitch-entry fit-string #f)
435 (ly:warning (_ "No open string for pitch ~a")
437 ;; here we handle assigned strings
439 (calc-fret pitch string tuning))
441 (ly:context-property context
444 (cond ((or (and (>= this-fret 0) (integer? this-fret))
445 (eq? handle-negative 'include))
446 (set-fret! pitch-entry string finger))
447 ((eq? handle-negative 'recalculate)
450 (_ "Requested string for pitch requires negative fret: string ~a pitch ~a")
453 (ly:warning (_ "Ignoring string request and recalculating."))
454 (list-set! string-fret-fingers
458 (list '() #f finger)))))
459 ((eq? handle-negative 'ignore)
462 (_ "Requested string for pitch requires negative fret: string ~a pitch ~a")
465 (ly:warning (_ "Ignoring note in tablature."))
466 (kill-note! string-fret-fingers
467 (cdr pitch-entry))))))))))
468 pitch-alist string-fret-fingers)
469 ;; handle notes without strings assigned -- sorted by pitch, so
470 ;; we need to use the alist to have the note number available
472 (lambda (pitch-entry)
473 (let* ((string-fret-finger (list-ref string-fret-fingers
475 (string (list-ref string-fret-finger 0))
476 (finger (if (= (length string-fret-finger) 3)
477 (list-ref string-fret-finger 2)
479 (pitch (car pitch-entry))
481 (find (lambda (string)
482 (string-qualifies string pitch))
484 (if (not (list-ref string-fret-finger 1))
486 (set-fret! pitch-entry fit-string finger)
489 (list-ref notes (cdr pitch-entry))
490 (_ "No string for pitch ~a (given frets ~a)")
493 (kill-note! string-fret-fingers
494 (cdr pitch-entry)))))))
495 (sort pitch-alist (lambda (pitch-entry-a pitch-entry-b)
496 (ly:pitch<? (car pitch-entry-b)
497 (car pitch-entry-a)))))
498 string-fret-fingers)) ;; end of determine-frets-and-strings
500 (define (get-predefined-fretboard predefined-fret-table tuning pitches)
501 "Search through @var{predefined-fret-table} looking for a predefined
502 fretboard with a key of @var{(tuning . pitches)}. The search will check
503 both up and down an octave in order to accomodate transposition of the
504 chords. Returns a placement-list."
506 (define (get-fretboard key)
508 (hash-get-handle predefined-fret-table key)))
510 (cdr hash-handle) ; return table entry
513 ;; body of get-predefined-fretboard
514 (let ((test-fretboard (get-fretboard (cons tuning pitches))))
515 (if (not (null? test-fretboard))
517 (let ((test-fretboard
519 (cons tuning (map (lambda (x) (shift-octave x 1)) pitches)))))
520 (if (not (null? test-fretboard))
523 (cons tuning (map (lambda (x) (shift-octave x -1))
526 ;; body of determine-frets
527 (let* ((predefined-fret-table
528 (ly:context-property context 'predefinedDiagramTable))
529 (tunings (ly:context-property context 'stringTunings))
530 (string-count (length tunings))
531 (grob (if (null? rest) '() (car rest)))
532 (pitches (map (lambda (x) (ly:event-property x 'pitch)) notes))
533 (defined-strings (map (lambda (x)
536 (or (string-number x) '())))
537 (car specified-info)))
538 (defined-fingers (map (lambda (x)
541 (ly:event-property x 'digit)))
542 (cadr specified-info)))
543 (default-strings (ly:context-property context 'defaultStrings '()))
544 (strings-used (if (and (zero? (entry-count defined-strings))
545 (not (zero? (entry-count default-strings))))
548 (predefined-fretboard
549 (if predefined-fret-table
550 (get-predefined-fretboard
551 predefined-fret-table
555 (if (null? predefined-fretboard)
557 (determine-frets-and-strings
561 (ly:context-property context 'minimumFret 0)
562 (ly:context-property context 'maximumFretStretch 4)
567 context grob (string-frets->placement-list
568 (filter (lambda (entry)
573 (placement-list->string-frets predefined-fretboard)
574 (create-fretboard context grob predefined-fretboard)))))
578 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
581 ;; The TabNoteHead tablatureFormat callbacks.
583 ;; Calculate the fret from pitch and string number as letter
584 ;; The fret letter is taken from 'fretLabels if present
585 (define-public (fret-letter-tablature-format
586 context string-number fret-number)
587 (let ((labels (ly:context-property context 'fretLabels)))
590 ((= 0 (length labels))
591 (string (integer->char (+ fret-number (char->integer #\a)))))
592 ((and (<= 0 fret-number) (< fret-number (length labels)))
593 (list-ref labels fret-number))
595 (ly:warning (_ "No label for fret ~a (on string ~a);
596 only ~a fret labels provided")
597 fret-number string-number (length labels))
600 ;; Display the fret number as a number
601 (define-public (fret-number-tablature-format
602 context string-number fret-number)
604 (format #f "~a" fret-number)))
606 ;; The 5-string banjo has got an extra string, the fifth (duh), which
607 ;; starts at the fifth fret on the neck. Frets on the fifth string
608 ;; are referred to relative to the other frets:
609 ;; the "first fret" on the fifth string is really the sixth fret
610 ;; on the banjo neck.
611 ;; We solve this by defining a new fret-number-tablature function:
612 (define-public (fret-number-tablature-format-banjo
613 context string-number fret-number)
615 (number->string (cond
616 ((and (> fret-number 0) (= string-number 5))
618 (else fret-number)))))
620 ;; Tab note head staff position functions
622 ;; Define where in the staff to display a given string. Some forms of
623 ;; tablature put the tab note heads in the spaces, rather than on the
626 (define-public (tablature-position-on-lines context string-number)
627 (let* ((string-tunings (ly:context-property context 'stringTunings))
628 (string-count (length string-tunings))
629 (string-one-topmost (ly:context-property context 'stringOneTopmost))
630 (staff-line (- (* 2 string-number) string-count 1)))
631 (if string-one-topmost
635 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
638 (define ((every-nth-bar-number-visible n) barnum mp)
639 (= 0 (modulo barnum n)))
640 (export every-nth-bar-number-visible)
642 (define ((modulo-bar-number-visible n m) barnum mp)
643 (and (> barnum 1) (= m (modulo barnum n))))
644 (export modulo-bar-number-visible)
646 (define ((set-bar-number-visibility n) tr)
647 (let ((bn (ly:context-property tr 'currentBarNumber)))
648 (ly:context-set-property! tr 'barNumberVisibility
649 (modulo-bar-number-visible n (modulo bn n)))))
650 (export set-bar-number-visibility)
652 (define-public (first-bar-number-invisible barnum mp)
655 (define-public (first-bar-number-invisible-save-broken-bars barnum mp)
657 (> (ly:moment-main-numerator mp) 0)))
659 (define-public (first-bar-number-invisible-and-no-parenthesized-bar-numbers barnum mp)
661 (= (ly:moment-main-numerator mp) 0)))
663 (define-public (robust-bar-number-function barnum measure-pos alt-number context)
664 (define (get-number-and-power an pow)
665 (if (<= an alt-number)
666 (get-number-and-power (+ an (expt 26 (1+ pow))) (1+ pow))
667 (cons (+ alt-number (- (expt 26 pow) an)) (1- pow))))
668 (define (make-letter so-far an pow)
671 (let ((pos (modulo (quotient an (expt 26 pow)) 26)))
672 (make-letter (string-append so-far
673 (substring "abcdefghijklmnopqrstuvwxyz"
678 (let* ((number-and-power (get-number-and-power 0 0))
679 (begin-measure (= 0 (ly:moment-main-numerator measure-pos)))
680 (maybe-open-parenthesis (if begin-measure "" "("))
681 (maybe-close-parenthesis (if begin-measure "" ")")))
682 (markup (string-append maybe-open-parenthesis
683 (number->string barnum)
685 (car number-and-power)
686 (cdr number-and-power))
687 maybe-close-parenthesis))))
689 (define-public (all-bar-numbers-visible barnum mp) #t)
692 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
693 ;; percent repeat counters
695 (define ((every-nth-repeat-count-visible n) count context)
696 (= 0 (modulo count n)))
697 (export every-nth-repeat-count-visible)
699 (define-public (all-repeat-counts-visible count context) #t)
701 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
702 ;; make-engraver helper macro
704 (defmacro-public make-engraver forms
705 "Helper macro for creating Scheme engravers.
707 The usual form for an engraver is an association list (or alist)
708 mapping symbols to either anonymous functions or to another such
711 @code{make-engraver} accepts forms where the first element is either
712 an argument list starting with the respective symbol, followed by the
713 function body (comparable to the way @code{define} is used for
714 defining functions), or a single symbol followed by subordinate forms
715 in the same manner. You can also just make an alist pair
716 literally (the @samp{car} is quoted automatically) as long as the
717 unevaluated @samp{cdr} is not a pair. This is useful if you already
718 have defined your engraver functions separately.
720 Symbols mapping to a function would be @code{initialize},
721 @code{start-translation-timestep}, @code{process-music},
722 @code{process-acknowledged}, @code{stop-translation-timestep}, and
723 @code{finalize}. Symbols mapping to another alist specified in the
724 same manner are @code{listeners} with the subordinate symbols being
725 event classes, and @code{acknowledgers} and @code{end-acknowledgers}
726 with the subordinate symbols being interfaces."
727 (let loop ((forms forms))
728 (if (cheap-list? forms)
730 ,@(map (lambda (form)
731 (if (pair? (car form))
732 `(cons ',(caar form) (lambda ,(cdar form) ,@(cdr form)))
733 `(cons ',(car form) ,(loop (cdr form)))))