X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Ftranslation-functions.scm;h=49d8768eb40500c9b1a65c1e9625adfb66e43f9e;hb=e7fbd58f58dce11d8105b078447f239b68caf160;hp=cc94b67acfbeb2aae9c3364d577e937b4d89d5c5;hpb=ac45f622a1b01a089c056d021741e92933161f82;p=lilypond.git diff --git a/scm/translation-functions.scm b/scm/translation-functions.scm index cc94b67acf..49d8768eb4 100644 --- a/scm/translation-functions.scm +++ b/scm/translation-functions.scm @@ -17,6 +17,24 @@ ;;;; along with LilyPond. If not, see . +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; clefs + +(define-public (clef-transposition-markup oct style) + "The transposition sign formatting function. @var{oct} is supposed to be +a string holding the transposition number, @var{style} determines the +way the transposition number is displayed." + (let* ((delim (if (symbol? style) + (case style + ((parenthesized) (cons "(" ")")) + ((bracketed) (cons "[" "]")) + (else (cons "" ""))) + (cons "" ""))) + (text (string-concatenate (list (car delim) oct (cdr delim))))) + + (make-vcenter-markup text))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; metronome marks @@ -264,6 +282,12 @@ dot placement entries." (length (filter (lambda (x) (not (null? x))) art-list))) + (define (string-number event) + "Get the string-number from @var{event}. Return @var{#f} +if no string-number is present." + (let ((num (ly:event-property event 'string-number))) + (and (integer? num) (positive? num) num))) + (define (determine-frets-and-strings notes defined-strings @@ -276,13 +300,17 @@ dot placement entries." along with @var{minimum-fret}, @var{maximum-stretch}, and @var{tuning}. Returns a list of @code{(string fret finger) lists." + + (define restrain-open-strings (ly:context-property context + 'restrainOpenStrings + #f)) (define specified-frets '()) (define free-strings (iota (length tuning) 1)) (define (calc-fret pitch string tuning) "Calculate the fret to play @var{pitch} on @var{string} with @var{tuning}." - (- (ly:pitch-semitones pitch) (ly:pitch-semitones (list-ref tuning (1- string))))) + (* 2 (- (ly:pitch-tones pitch) (ly:pitch-tones (list-ref tuning (1- string)))))) (define (note-pitch note) "Get the pitch (in semitones) from @var{note}." @@ -296,21 +324,13 @@ if no fingering is present." (map (lambda (art) (let* ((num (ly:event-property art 'digit))) - (if (and (eq? 'fingering-event (ly:event-property art 'class)) + (if (and (ly:in-event-class? art 'fingering-event) (number? num) (> num 0)) (set! finger-found num)))) articulations) finger-found)) - (define (string-number event) - "Get the string-number from @var{event}. Return @var{#f} -if no string-number is present." - (let ((num (ly:event-property event 'string-number))) - (if (number? num) - num - #f))) - (define (delete-free-string string) (if (number? string) (set! free-strings @@ -318,30 +338,27 @@ if no string-number is present." (define (close-enough fret) "Decide if @var{fret} is acceptable, given the already used frets." - (if (null? specified-frets) - #t - (reduce - (lambda (x y) - (and x y)) - #t - (map (lambda (specced-fret) - (or (eq? 0 specced-fret) - (eq? 0 fret) - (>= maximum-stretch (abs (- fret specced-fret))))) - specified-frets)))) + (every (lambda (specced-fret) + (or (zero? specced-fret) + (zero? fret) + (>= maximum-stretch (abs (- fret specced-fret))))) + specified-frets)) (define (string-qualifies string pitch) "Can @var{pitch} be played on @var{string}, given already placed notes?" (let* ((fret (calc-fret pitch string tuning))) - (and (or (eq? fret 0) (>= fret minimum-fret)) + (and (or (and (not restrain-open-strings) + (zero? fret)) + (>= fret minimum-fret)) + (integer? fret) (close-enough fret)))) (define (open-string string pitch) "Is @var{pitch} and open-string note on @var{string}, given the current tuning?" (let* ((fret (calc-fret pitch string tuning))) - (eq? fret 0))) + (zero? fret))) (define (set-fret! pitch-entry string finger) (let ((this-fret (calc-fret (car pitch-entry) @@ -349,7 +366,10 @@ the current tuning?" tuning))) (if (< this-fret 0) (ly:warning (_ "Negative fret for pitch ~a on string ~a") - (car pitch-entry) string)) + (car pitch-entry) string) + (if (not (integer? this-fret)) + (ly:warning (_ "Missing fret for pitch ~a on string ~a") + (car pitch-entry) string))) (delete-free-string string) (set! specified-frets (cons this-fret specified-frets)) (list-set! string-fret-fingers @@ -367,22 +387,14 @@ the current tuning?" defined-strings defined-fingers)) ;;; body of determine-frets-and-strings - (let* ((pitch-alist (apply (lambda (mylist) - (let ((index -1)) - (map (lambda (note) - (begin - (set! index (1+ index)) - (cons (note-pitch note) - index))) - mylist))) - notes '())) - (pitches (map note-pitch notes))) + (let* ((pitches (map note-pitch notes)) + (pitch-alist (map cons pitches (iota (length pitches))))) ;; handle notes with strings assigned and fingering of 0 (for-each (lambda (pitch-entry string-fret-finger) (let* ((string (list-ref string-fret-finger 0)) - (finger (if (eq? (length string-fret-finger) 3) + (finger (if (= (length string-fret-finger) 3) (list-ref string-fret-finger 2) '())) (pitch (car pitch-entry)) @@ -390,8 +402,8 @@ the current tuning?" #f finger))) (if (or (not (null? string)) - (eq? digit 0)) - (if (eq? digit 0) + (eqv? digit 0)) + (if (eqv? digit 0) ;; here we handle fingers of 0 -- open strings (let ((fit-string (find (lambda (string) @@ -408,7 +420,7 @@ the current tuning?" (ly:context-property context 'handleNegativeFrets 'recalculate))) - (cond ((or (>= this-fret 0) + (cond ((or (and (>= this-fret 0) (integer? this-fret)) (eq? handle-negative 'include)) (set-fret! pitch-entry string finger)) ((eq? handle-negative 'recalculate) @@ -440,7 +452,7 @@ the current tuning?" (let* ((string-fret-finger (list-ref string-fret-fingers (cdr pitch-entry))) (string (list-ref string-fret-finger 0)) - (finger (if (eq? (length string-fret-finger) 3) + (finger (if (= (length string-fret-finger) 3) (list-ref string-fret-finger 2) '())) (pitch (car pitch-entry)) @@ -498,7 +510,7 @@ chords. Returns a placement-list." (defined-strings (map (lambda (x) (if (null? x) x - (ly:event-property x 'string-number))) + (or (string-number x) '()))) (car specified-info))) (defined-fingers (map (lambda (x) (if (null? x)