X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Ftranslation-functions.scm;h=314e66ff59b8783263efcbcaa36f0f721a240f18;hb=6e624bc354e691c7a0b9035e6cd9bee4257fe101;hp=c6eefac9f5e0843380819351cbb54ec25440c4be;hpb=16bdb67bb1ce1f52380b36e264869c2b61aa3553;p=lilypond.git diff --git a/scm/translation-functions.scm b/scm/translation-functions.scm index c6eefac9f5..314e66ff59 100644 --- a/scm/translation-functions.scm +++ b/scm/translation-functions.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; (c) 1998--2010 Han-Wen Nienhuys +;;;; (c) 1998--2011 Han-Wen Nienhuys ;;;; Jan Nieuwenhuizen ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify @@ -20,8 +20,12 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; metronome marks -(define-public (format-metronome-markup text dur count context) - (let* ((hide-note (eq? #t (ly:context-property context 'tempoHideNote)))) +(define-public (format-metronome-markup event context) + (let ((hide-note (ly:context-property context 'tempoHideNote #f)) + (text (ly:event-property event 'text)) + (dur (ly:event-property event 'tempo-unit)) + (count (ly:event-property event 'metronome-count))) + (metronome-markup text dur count hide-note))) (define-public (metronome-markup text dur count hide-note) @@ -209,18 +213,18 @@ (define-public (determine-frets context notes specified-info . rest) "Determine string numbers and frets for playing @var{notes} -as a chord, given specified information @var{specified-info}. +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 +specified strings @code{defined-strings} and +specified fingerings @code{defined-fingers}. Only a fingering of@tie{}0 +will affect the fret selection, as it specifies an open string. +If @code{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 -created. Otherwise, a list of (string fret finger) lists will -be returned)." +@code{FretBoard} grob, and a fretboard will be +created. Otherwise, a list of @code{(string fret finger)} lists will +be returned." ;; helper functions @@ -228,20 +232,21 @@ be returned)." "Convert @var{string-frets} to @code{fret-diagram-verbose} dot placement entries." (let* ((placements (list->vector - (map (lambda (x) (list 'mute (1+ x))) - (iota string-count))))) + (map (lambda (x) (list 'mute x)) + (iota string-count 1))))) (for-each (lambda (sf) (let* ((string (car sf)) (fret (cadr sf)) (finger (caddr sf))) (vector-set! - placements (1- string) - (if (= 0 fret) - (list 'open string) - (if finger - (list 'place-fret string fret finger) - (list 'place-fret string fret)))))) + placements + (1- string) + (if (= 0 fret) + (list 'open string) + (if finger + (list 'place-fret string fret finger) + (list 'place-fret string fret)))))) string-frets) (vector->list placements))) @@ -255,9 +260,207 @@ dot placement entries." placement-list))) (define (entry-count art-list) + "Count the number of entries in a list of articulations." (length (filter (lambda (x) (not (null? x))) art-list))) + (define (determine-frets-and-strings + notes + defined-strings + defined-fingers + minimum-fret + maximum-stretch + tuning) + "Determine the frets and strings used to play the notes in +@var{notes}, given @var{defined-strings} and @var{defined-fingers} +along with @var{minimum-fret}, @var{maximum-stretch}, and +@var{tuning}. Returns a list of @code{(string fret finger) lists." + + (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))))) + + (define (note-pitch note) + "Get the pitch (in semitones) from @var{note}." + (ly:event-property note 'pitch)) + + (define (note-finger ev) + "Get the fingering from @var{ev}. Return @var{#f} +if no fingering is present." + (let* ((articulations (ly:event-property ev 'articulations)) + (finger-found #f)) + (map (lambda (art) + (let* ((num (ly:event-property art 'digit))) + + (if (and (eq? 'fingering-event (ly:event-property art 'class)) + (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 + (delete string free-strings)))) + + (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) + (>= 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 (>= fret minimum-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))) + + (define (set-fret! pitch-entry string finger) + (let ((this-fret (calc-fret (car pitch-entry) + string + tuning))) + (if (< this-fret 0) + (ly:warning (_ "Negative 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 + (cdr pitch-entry) + (list string this-fret finger)))) + + (define (kill-note! string-fret-fingers note-index) + (list-set! string-fret-fingers note-index (list #f #t))) + + (define string-fret-fingers + (map (lambda (string finger) + (if (null? finger) + (list string #f) + (list string #f finger))) + 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))) + + ;; 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) + (list-ref string-fret-finger 2) + '())) + (pitch (car pitch-entry)) + (digit (if (null? finger) + #f + finger))) + (if (or (not (null? string)) + (eq? digit 0)) + (if (eq? digit 0) + ;; here we handle fingers of 0 -- open strings + (let ((fit-string + (find (lambda (string) + (open-string string pitch)) + free-strings))) + (if fit-string + (set-fret! pitch-entry fit-string #f) + (ly:warning (_ "No open string for pitch ~a") + pitch))) + ;; here we handle assigned strings + (let ((this-fret + (calc-fret pitch string tuning)) + (handle-negative + (ly:context-property context + 'handleNegativeFrets + 'recalculate))) + (cond ((or (>= this-fret 0) + (eq? handle-negative 'include)) + (set-fret! pitch-entry string finger)) + ((eq? handle-negative 'recalculate) + (begin + (ly:warning + (_ "Requested string for pitch requires negative fret: string ~a pitch ~a") + string + pitch) + (ly:warning (_ "Ignoring string request and recalculating.")) + (list-set! string-fret-fingers + (cdr pitch-entry) + (if (null? finger) + (list '() #f) + (list '() #f finger))))) + ((eq? handle-negative 'ignore) + (begin + (ly:warning + (_ "Requested string for pitch requires negative fret: string ~a pitch ~a") + string + pitch) + (ly:warning (_ "Ignoring note in tablature.")) + (kill-note! string-fret-fingers + (cdr pitch-entry)))))))))) + pitch-alist string-fret-fingers) + ;; handle notes without strings assigned -- sorted by pitch, so + ;; we need to use the alist to have the note number available + (for-each + (lambda (pitch-entry) + (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) + (list-ref string-fret-finger 2) + '())) + (pitch (car pitch-entry)) + (fit-string + (find (lambda (string) + (string-qualifies string pitch)) + free-strings))) + (if (not (list-ref string-fret-finger 1)) + (if fit-string + (set-fret! pitch-entry fit-string finger) + (begin + (ly:warning (_ "No string for pitch ~a (given frets ~a)") + pitch + specified-frets) + (kill-note! string-fret-fingers + (cdr pitch-entry))))))) + (sort pitch-alist (lambda (pitch-entry-a pitch-entry-b) + (ly:pitchplacement-list - string-frets string-count)))) + (filter (lambda (entry) + (car entry)) + string-frets) + string-count)))) (if (null? grob) (placement-list->string-frets predefined-fretboard) (create-fretboard context grob predefined-fretboard))))) -(define (determine-frets-and-strings - 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)))) - - (define (note-pitch a) - (ly:event-property a 'pitch)) - - (define (note-pitch>? a b) - (ly:pitch num 0)) - (set! finger-found num)))) - articulations) - - finger-found)) - - (define (string-number event) - (let ((num (ly:event-property event 'string-number))) - (if (number? num) - num - #f))) - - (define (delete-free-string string) - (if (number? string) - (set! free-strings - (delete string free-strings)))) - - (define free-strings '()) - (define unassigned-notes '()) - (define specified-frets '()) - - (define (close-enough fret) - (if (null? specified-frets) - #t - (reduce - (lambda (x y) - (and x y)) - #t - (map (lambda (specced-fret) - (or (eq? 0 specced-fret) - (>= maximum-stretch (abs (- fret specced-fret))))) - specified-frets)))) - - (define (string-qualifies string pitch) - (let* ((fret (calc-fret pitch string tuning))) - (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))) - (set! string-fret-fingering-tuples - (cons (list string - this-fret - (note-finger note)) - string-fret-fingering-tuples)) - (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 - (pad-list defined-strings notes) - - ;; get defined-fingers same length as notes - (pad-list defined-fingers notes) - - ;; handle notes with strings assigned and fingering of 0 - (for-each - (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))) - (if fit-string - (set-fret note fit-string) - (ly:warning (_ "No string for pitch ~a (given frets ~a)") - (note-pitch note) - specified-frets)))) - (sort unassigned-notes note-pitch>?)) - - string-fret-fingering-tuples) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; tablature @@ -499,7 +565,7 @@ only ~a fret labels provided") (define-public (fret-number-tablature-format context string-number fret-number) (make-vcenter-markup - (format "~a" fret-number))) + (format #f "~a" fret-number))) ;; The 5-string banjo has got a extra string, the fifth (duh), which ;; starts at the fifth fret on the neck. Frets on the fifth string