X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Ftranslation-functions.scm;h=a2ee8b9ddb26766184e5f639f34581ac9231ace5;hb=17f11c2f5ab963bfb07b7652b4860dc4dda5540a;hp=683f2aaae405c6fd447cc85448894e8980d37285;hpb=88bb870e3ca6c4f87866c629fa157847ea80bede;p=lilypond.git diff --git a/scm/translation-functions.scm b/scm/translation-functions.scm index 683f2aaae4..a2ee8b9ddb 100644 --- a/scm/translation-functions.scm +++ b/scm/translation-functions.scm @@ -31,14 +31,27 @@ (ly:duration-dot-count dur) 1)) #f)) - (note-markup (if (and (not hide-note) (number? count) (> count 0) ) + (count-markup (cond ((number? count) + (if (> count 0) + (make-simple-markup (number->string count)) + #f)) + ((pair? count) + (make-concat-markup + (list + (make-simple-markup (number->string (car count))) + (make-simple-markup " ") + (make-simple-markup "–") + (make-simple-markup " ") + (make-simple-markup (number->string (cdr count)))))) + (else #f))) + (note-markup (if (and (not hide-note) count-markup) (make-concat-markup (list (make-general-align-markup Y DOWN note-mark) (make-simple-markup " ") (make-simple-markup "=") (make-simple-markup " ") - (make-simple-markup (number->string count)))) + count-markup)) #f)) (text-markup (if (not (null? text)) (make-bold-markup text) @@ -194,9 +207,15 @@ (set! (ly:grob-property grob 'dot-placement-list) placement-list))) (define-public - (determine-frets context notes defined-strings . rest) + (determine-frets context notes specified-info . rest) "Determine string numbers and frets for playing @var{notes} -as a chord, given specified string numbers @var{defined-strings}. +as a chord, given specified information @var{specified-info}. +@var{specified-info} is a list with two list elements, +specified strings @var{defined-strings} and +specified fingerings @var{defined-fingers}. Only a fingering of +0 will affect the fret selection, as it specifies an open string. +If @var{defined-strings} is @code{'()}, the context property +@code{defaultStrings} will be used as a list of defined strings. Will look for predefined fretboards if @code{predefinedFretboardTable} is not @code {#f}. If @var{rest} is present, it contains the FretBoard grob, and a fretboard will be @@ -232,8 +251,12 @@ dot placement entries." (cdr x) (list (cadr x) 0))) (filter (lambda (l) (or (eq? (car l) 'place-fret) - (eq? (car l) 'open))) placement-list))) + (eq? (car l) 'open))) + placement-list))) + (define (entry-count art-list) + (length (filter (lambda (x) (not (null? x))) + art-list))) (define (get-predefined-fretboard predefined-fret-table tuning pitches) "Search through @var{predefined-fret-table} looking for a predefined @@ -268,6 +291,21 @@ chords. Returns a placement-list." (string-count (length tunings)) (grob (if (null? rest) '() (car rest))) (pitches (map (lambda (x) (ly:event-property x 'pitch)) notes)) + (defined-strings (map (lambda (x) + (if (null? x) + x + (ly:event-property x 'string-number))) + (car specified-info))) + (defined-fingers (map (lambda (x) + (if (null? x) + x + (ly:event-property x 'digit))) + (cadr specified-info))) + (default-strings (ly:context-property context 'defaultStrings '())) + (strings-used (if (and (zero? (entry-count defined-strings)) + (not (zero? (entry-count default-strings)))) + default-strings + defined-strings)) (predefined-fretboard (if predefined-fret-table (get-predefined-fretboard @@ -275,12 +313,12 @@ chords. Returns a placement-list." tunings pitches) '()))) - (if (null? predefined-fretboard) (let ((string-frets (determine-frets-and-strings notes - defined-strings + strings-used + defined-fingers (ly:context-property context 'minimumFret 0) (ly:context-property context 'maximumFretStretch 4) tunings))) @@ -295,10 +333,15 @@ chords. Returns a placement-list." (define (determine-frets-and-strings - notes defined-strings minimum-fret maximum-stretch tuning) + notes + defined-strings + defined-fingers + minimum-fret + maximum-stretch + tuning) (define (calc-fret pitch string tuning) - (- (ly:pitch-semitones pitch) (list-ref tuning (1- string)))) + (- (ly:pitch-semitones pitch) (ly:pitch-semitones (list-ref tuning (1- string))))) (define (note-pitch a) (ly:event-property a 'pitch)) @@ -315,7 +358,8 @@ chords. Returns a placement-list." (let* ((num (ly:event-property art 'digit))) (if (and (eq? 'fingering-event (ly:event-property art 'class)) - (number? num)) + (number? num) + (> num 0)) (set! finger-found num)))) articulations) @@ -327,7 +371,6 @@ chords. Returns a placement-list." num #f))) - (define (delete-free-string string) (if (number? string) (set! free-strings @@ -345,7 +388,8 @@ chords. Returns a placement-list." (and x y)) #t (map (lambda (specced-fret) - (> maximum-stretch (abs (- fret specced-fret)))) + (or (eq? 0 specced-fret) + (>= maximum-stretch (abs (- fret specced-fret))))) specified-frets)))) (define (string-qualifies string pitch) @@ -353,12 +397,19 @@ chords. Returns a placement-list." (and (>= fret minimum-fret) (close-enough fret)))) + (define (open-string string pitch) + (let* ((fret (calc-fret pitch string tuning))) + (eq? fret 0))) + (define string-fret-fingering-tuples '()) (define (set-fret note string) (let ((this-fret (calc-fret (ly:event-property note 'pitch) string tuning))) + (if (< this-fret 0) + (ly:warning (_ "Negative fret for pitch ~a on string ~a") + (note-pitch note) string)) (set! string-fret-fingering-tuples (cons (list string this-fret @@ -367,35 +418,60 @@ chords. Returns a placement-list." (delete-free-string string) (set! specified-frets (cons this-fret specified-frets)))) + (define (pad-list target template) + (while (< (length target) (length template)) + (set! target (if (null? target) + '(()) + (append target '(())))))) + ;;; body of determine-frets-and-strings (set! free-strings (map 1+ (iota (length tuning)))) ;; get defined-strings same length as notes - (while (< (length defined-strings) (length notes)) - (set! defined-strings (append defined-strings '(())))) + (pad-list defined-strings notes) + + ;; get defined-fingers same length as notes + (pad-list defined-fingers notes) - ;; handle notes with strings assigned + ;; handle notes with strings assigned and fingering of 0 (for-each - (lambda (note string) - (if (null? string) - (set! unassigned-notes (cons note unassigned-notes)) - (let ((this-string (string-number string))) - (delete-free-string this-string) - (set-fret note this-string)))) - notes defined-strings) + (lambda (note string finger) + (let ((digit (if (null? finger) + #f + finger))) + (if (and (null? string) + (not (eq? digit 0))) + (set! unassigned-notes (cons note unassigned-notes)) + (if (eq? digit 0) + (let ((fit-string + (find (lambda (string) + (open-string string (note-pitch note))) + free-strings))) + (if fit-string + (begin + (delete-free-string fit-string) + (set-fret note fit-string)) + (begin + (ly:warning (_ "No open string for pitch ~a") + (note-pitch note)) + (set! unassigned-notes (cons note unassigned-notes))))) + (begin + (delete-free-string string) + (set-fret note string)))))) + notes defined-strings defined-fingers) ;; handle notes without strings assigned (for-each (lambda (note) - (let* ((fit-string - (find (lambda (string) - (string-qualifies string (note-pitch note))) - free-strings))) + (let ((fit-string + (find (lambda (string) + (string-qualifies string (note-pitch note))) + free-strings))) (if fit-string (set-fret note fit-string) - (ly:warning "No string for pitch ~a (given frets ~a)" - (note-pitch note) - specified-frets)))) + (ly:warning (_ "No string for pitch ~a (given frets ~a)") + (note-pitch note) + specified-frets)))) (sort unassigned-notes note-pitch>?)) string-fret-fingering-tuples) @@ -417,10 +493,10 @@ chords. Returns a placement-list." ((and (<= 0 fret-number) (< fret-number (length labels))) (list-ref labels fret-number)) (else - (ly:warning "No label for fret ~a (on string ~a); -only ~a fret labels provided" - fret-number string-number (length labels)) - "."))))) + (ly:warning (_ "No label for fret ~a (on string ~a); +only ~a fret labels provided") + fret-number string-number (length labels)) + "."))))) ;; Display the fret number as a number (define-public (fret-number-tablature-format