X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Ftranslation-functions.scm;h=5877674d10e9e08d3d65538e762048b3b281627b;hb=ee0ef98a35634718033d505deb8a355e05513d6a;hp=94862688fdb522ec369130ae485000983bafc582;hpb=2940cdd12c135ef94e4c95ac815e76014eef9c79;p=lilypond.git diff --git a/scm/translation-functions.scm b/scm/translation-functions.scm index 94862688fd..5877674d10 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--2011 Han-Wen Nienhuys +;;;; (c) 1998--2012 Han-Wen Nienhuys ;;;; Jan Nieuwenhuizen ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify @@ -17,6 +17,24 @@ ;;;; along with LilyPond. If not, see . +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; clefs + +(define-public (clef-octavation-markup oct style) + "The octavation sign formatting function. @var{oct} is supposed to be +a string holding the octavation number, @var{style} determines the +way the octavation 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,29 +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) - (>= 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 (>= 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) @@ -348,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 @@ -366,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)) @@ -389,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) @@ -407,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) @@ -439,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)) @@ -497,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) @@ -565,7 +578,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 @@ -599,10 +612,10 @@ only ~a fret labels provided") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; bar numbers -(define-public ((every-nth-bar-number-visible n) barnum) +(define-public ((every-nth-bar-number-visible n) barnum mp) (= 0 (modulo barnum n))) -(define-public ((modulo-bar-number-visible n m) barnum) +(define-public ((modulo-bar-number-visible n m) barnum mp) (and (> barnum 1) (= m (modulo barnum n)))) (define-public ((set-bar-number-visibility n) tr) @@ -610,9 +623,44 @@ only ~a fret labels provided") (ly:context-set-property! tr 'barNumberVisibility (modulo-bar-number-visible n (modulo bn n))))) -(define-public (first-bar-number-invisible barnum) (> barnum 1)) - -(define-public (all-bar-numbers-visible barnum) #t) +(define-public (first-bar-number-invisible barnum mp) + (> barnum 1)) + +(define-public (first-bar-number-invisible-save-broken-bars barnum mp) + (or (> barnum 1) + (> (ly:moment-main-numerator mp) 0))) + +(define-public (first-bar-number-invisible-and-no-parenthesized-bar-numbers barnum mp) + (and (> barnum 1) + (= (ly:moment-main-numerator mp) 0))) + +(define-public (robust-bar-number-function barnum measure-pos alt-number context) + (define (get-number-and-power an pow) + (if (<= an alt-number) + (get-number-and-power (+ an (expt 26 (1+ pow))) (1+ pow)) + (cons (+ alt-number (- (expt 26 pow) an)) (1- pow)))) + (define (make-letter so-far an pow) + (if (< pow 0) + so-far + (let ((pos (modulo (quotient an (expt 26 pow)) 26))) + (make-letter (string-append so-far + (substring "abcdefghijklmnopqrstuvwxyz" + pos + (1+ pos))) + an + (1- pow))))) + (let* ((number-and-power (get-number-and-power 0 0)) + (begin-measure (= 0 (ly:moment-main-numerator measure-pos))) + (maybe-open-parenthesis (if begin-measure "" "(")) + (maybe-close-parenthesis (if begin-measure "" ")"))) + (markup (string-append maybe-open-parenthesis + (number->string barnum) + (make-letter "" + (car number-and-power) + (cdr number-and-power)) + maybe-close-parenthesis)))) + +(define-public (all-bar-numbers-visible barnum mp) #t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -622,3 +670,39 @@ only ~a fret labels provided") (= 0 (modulo count n))) (define-public (all-repeat-counts-visible count context) #t) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; make-engraver helper macro + +(defmacro-public make-engraver forms + "Helper macro for creating Scheme engravers. + +The usual form for an engraver is an association list (or alist) +mapping symbols to either anonymous functions or to another such +alist. + +@code{make-engraver} accepts forms where the first element is either +an argument list starting with the respective symbol, followed by the +function body (comparable to the way @code{define} is used for +defining functions), or a single symbol followed by subordinate forms +in the same manner. You can also just make an alist pair +literally (the @samp{car} is quoted automatically) as long as the +unevaluated @samp{cdr} is not a pair. This is useful if you already +have defined your engraver functions separately. + +Symbols mapping to a function would be @code{initialize}, +@code{start-translation-timestep}, @code{process-music}, +@code{process-acknowledged}, @code{stop-translation-timestep}, and +@code{finalize}. Symbols mapping to another alist specified in the +same manner are @code{listeners} with the subordinate symbols being +event classes, and @code{acknowledgers} and @code{end-acknowledgers} +with the subordinate symbols being interfaces." + (let loop ((forms forms)) + (if (cheap-list? forms) + `(list + ,@(map (lambda (form) + (if (pair? (car form)) + `(cons ',(caar form) (lambda ,(cdar form) ,@(cdr form))) + `(cons ',(car form) ,(loop (cdr form))))) + forms)) + forms)))