X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Ftranslation-functions.scm;h=4479d3ae1b24f51e87671fccdc99cf100f889715;hb=9e781b7dc83b60a543ce218aa1a5f139f74c760f;hp=facabd8ab59f6c1f49756fdead347d8ce3bb7882;hpb=c1d5bb448321d688185e0c6b798575d4c325ae80;p=lilypond.git diff --git a/scm/translation-functions.scm b/scm/translation-functions.scm index facabd8ab5..4479d3ae1b 100644 --- a/scm/translation-functions.scm +++ b/scm/translation-functions.scm @@ -1,7 +1,7 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; (c) 1998--2011 Han-Wen Nienhuys -;;;; Jan Nieuwenhuizen +;;;; (c) 1998--2014 Han-Wen Nienhuys +;;;; Jan Nieuwenhuizen ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -17,60 +17,98 @@ ;;;; 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 -(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) - (let* ((note-mark (if (and (not hide-note) (ly:duration? dur)) - (make-smaller-markup - (make-note-by-number-markup (ly:duration-log dur) - (ly:duration-dot-count dur) - 1)) - #f)) - (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))) +;; We give 'styled-metronome-markup' an optional argument, 'glyph-font', to +;; prepare using other fonts than 'fetaMusic. +;; Currently it ensures that the default-fonts are used by the +;; markup-command 'note-by-number' in 'metronome-markup' (see below). +(define*-public + ((styled-metronome-markup #:optional (glyph-font 'default)) + 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 glyph-font text dur count hide-note))) + +(define-public format-metronome-markup + (styled-metronome-markup)) + +(define (metronome-markup glyph-font text dur count hide-note) + (let* ((note-mark + (if (and (not hide-note) (ly:duration? dur)) + (make-smaller-markup + ;; We insert the (default)-font for flag-glyphs and + ;; note-head-glyphs to prepare the possibility to use + ;; other fonts and to make possible using + ;; \override MetronomeMark #'font-name = # + ;; without affecting the note/flag-glyphs. + (make-override-markup (cons 'font-name glyph-font) + (make-note-by-number-markup + (ly:duration-log dur) + (ly:duration-dot-count dur) + UP))) + #f)) + (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 " ") - count-markup)) - #f)) + (make-concat-markup + (list + (make-general-align-markup Y DOWN note-mark) + (make-simple-markup " ") + (make-simple-markup "=") + (make-simple-markup " ") + count-markup)) + #f)) (text-markup (if (not (null? text)) - (make-bold-markup text) - #f))) + (make-bold-markup text) + #f))) (if text-markup - (if (and note-markup (not hide-note)) - (make-line-markup (list text-markup - (make-concat-markup - (list (make-simple-markup "(") - note-markup - (make-simple-markup ")"))))) - (make-line-markup (list text-markup))) - (if note-markup - (make-line-markup (list note-markup)) - (make-null-markup))))) + (if (and note-markup (not hide-note)) + (make-line-markup (list text-markup + (make-concat-markup + (list (make-simple-markup "(") + note-markup + (make-simple-markup ")"))))) + (make-line-markup (list text-markup))) + (if note-markup + (make-line-markup (list note-markup)) + (make-null-markup))))) (define-public (format-mark-alphabet mark context) (make-bold-markup (make-markalphabet-markup (1- mark)))) @@ -89,7 +127,7 @@ (define-public (format-mark-barnumbers mark context) (make-bold-markup (number->string (ly:context-property context - 'currentBarNumber)))) + 'currentBarNumber)))) (define-public (format-mark-box-letters mark context) (make-bold-markup (make-box-markup (make-markletter-markup (1- mark))))) @@ -105,13 +143,13 @@ (define-public (format-mark-box-barnumbers mark context) (make-bold-markup (make-box-markup - (number->string (ly:context-property context - 'currentBarNumber))))) + (number->string (ly:context-property context + 'currentBarNumber))))) (define-public (format-mark-circle-barnumbers mark context) (make-bold-markup (make-circle-markup - (number->string (ly:context-property context - 'currentBarNumber))))) + (number->string (ly:context-property context + 'currentBarNumber))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -119,79 +157,79 @@ (define-public (format-bass-figure figure event context) (let* ((fig (ly:event-property event 'figure)) - (fig-markup (if (number? figure) - - ;; this is not very elegant, but center-aligning - ;; all digits is problematic with other markups, - ;; and shows problems in the (lack of) overshoot - ;; of feta-alphabet glyphs. - ((if (<= 10 figure) - (lambda (y) (make-translate-scaled-markup - (cons -0.7 0) y)) - identity) - - (cond - ((eq? #t (ly:event-property event 'diminished)) - (markup #:slashed-digit figure)) - ((eq? #t (ly:event-property event 'augmented-slash)) - (markup #:backslashed-digit figure)) - (else (markup #:number (number->string figure 10))))) - #f)) - - (alt (ly:event-property event 'alteration)) - (alt-markup - (if (number? alt) - (markup - #:general-align Y DOWN #:fontsize - (if (not (= alt DOUBLE-SHARP)) - -2 2) - (alteration->text-accidental-markup alt)) - #f)) - - (plus-markup (if (eq? #t (ly:event-property event 'augmented)) - (markup #:number "+") - #f)) - - (alt-dir (ly:context-property context 'figuredBassAlterationDirection)) - (plus-dir (ly:context-property context 'figuredBassPlusDirection))) + (fig-markup (if (number? figure) + + ;; this is not very elegant, but center-aligning + ;; all digits is problematic with other markups, + ;; and shows problems in the (lack of) overshoot + ;; of feta-alphabet glyphs. + ((if (<= 10 figure) + (lambda (y) (make-translate-scaled-markup + (cons -0.7 0) y)) + identity) + + (cond + ((eq? #t (ly:event-property event 'diminished)) + (markup #:slashed-digit figure)) + ((eq? #t (ly:event-property event 'augmented-slash)) + (markup #:backslashed-digit figure)) + (else (markup #:number (number->string figure 10))))) + #f)) + + (alt (ly:event-property event 'alteration)) + (alt-markup + (if (number? alt) + (markup + #:general-align Y DOWN #:fontsize + (if (not (= alt DOUBLE-SHARP)) + -2 2) + (alteration->text-accidental-markup alt)) + #f)) + + (plus-markup (if (eq? #t (ly:event-property event 'augmented)) + (markup #:number "+") + #f)) + + (alt-dir (ly:context-property context 'figuredBassAlterationDirection)) + (plus-dir (ly:context-property context 'figuredBassPlusDirection))) (if (and (not fig-markup) alt-markup) - (begin - (set! fig-markup (markup #:left-align #:pad-around 0.3 alt-markup)) - (set! alt-markup #f))) + (begin + (set! fig-markup (markup #:left-align #:pad-around 0.3 alt-markup)) + (set! alt-markup #f))) ;; hmm, how to get figures centered between note, and ;; lone accidentals too? ;; (if (markup? fig-markup) - ;; (set! - ;; fig-markup (markup #:translate (cons 1.0 0) - ;; #:center-align fig-markup))) + ;; (set! + ;; fig-markup (markup #:translate (cons 1.0 0) + ;; #:center-align fig-markup))) (if alt-markup - (set! fig-markup - (markup #:put-adjacent - X (if (number? alt-dir) - alt-dir - LEFT) - fig-markup - #:pad-x 0.2 alt-markup))) + (set! fig-markup + (markup #:put-adjacent + X (if (number? alt-dir) + alt-dir + LEFT) + fig-markup + #:pad-x 0.2 alt-markup))) (if plus-markup - (set! fig-markup - (if fig-markup - (markup #:put-adjacent - X (if (number? plus-dir) - plus-dir - LEFT) - fig-markup - #:pad-x 0.2 plus-markup) - plus-markup))) + (set! fig-markup + (if fig-markup + (markup #:put-adjacent + X (if (number? plus-dir) + plus-dir + LEFT) + fig-markup + #:pad-x 0.2 plus-markup) + plus-markup))) (if (markup? fig-markup) - (markup #:fontsize -2 fig-markup) - empty-markup))) + (markup #:fontsize -2 fig-markup) + empty-markup))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -201,12 +239,12 @@ "Convert @var{placement-list} into a fretboard @var{grob}." (let* ((tunings (ly:context-property context 'stringTunings)) - (my-string-count (length tunings)) - (details (ly:grob-property grob 'fret-diagram-details))) + (my-string-count (length tunings)) + (details (ly:grob-property grob 'fret-diagram-details))) ;; Add string-count from string-tunings to fret-diagram-details. (set! (ly:grob-property grob 'fret-diagram-details) - (acons 'string-count my-string-count details)) + (acons 'string-count my-string-count details)) ;; Create the dot-placement list for the grob (set! (ly:grob-property grob 'dot-placement-list) placement-list))) @@ -232,21 +270,22 @@ 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) + (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)))))) - string-frets) + (if finger + (list 'place-fret string fret finger) + (list 'place-fret string fret)))))) + string-frets) (vector->list placements))) (define (placement-list->string-frets placement-list) @@ -259,164 +298,203 @@ 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 (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 - defined-fingers - minimum-fret - maximum-stretch - tuning) + 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 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) - (- (ly:pitch-semitones pitch) (ly:pitch-semitones (list-ref tuning (1- string))))) - - (define (note-pitch a) - (ly:event-property a 'pitch)) + "Calculate the fret to play @var{pitch} on @var{string} with +@var{tuning}." + (* 2 (- (ly:pitch-tones pitch) (ly:pitch-tones (list-ref tuning (1- string)))))) - (define (note-pitch>? a b) - (ly:pitch num 0)) - (set! finger-found num)))) - articulations) - - finger-found)) + (finger-found #f)) + (for-each (lambda (art) + (let* ((num (ly:event-property art 'digit))) - (define (string-number event) - (let ((num (ly:event-property event 'string-number))) - (if (number? num) - num - #f))) + (if (and (ly:in-event-class? art 'fingering-event) + (number? num) + (> num 0)) + (set! finger-found num)))) + articulations) + finger-found)) (define (delete-free-string string) (if (number? string) - (set! free-strings - (delete string free-strings)))) - - (define free-strings '()) - (define unassigned-notes '()) - (define specified-frets '()) + (set! free-strings + (delete string free-strings)))) (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)))) + "Decide if @var{fret} is acceptable, given the already used 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) - (close-enough 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))) - - (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 - (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 '(())))))) + (zero? fret))) + + (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) + (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 + (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 - (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))))) - (let ((this-fret (calc-fret (note-pitch note) string tuning)) - (handle-negative - (ly:context-property context - 'handleNegativeFrets - 'recalculate))) - (cond ((or (>= this-fret 0) - (eq? handle-negative 'include)) - (begin - (delete-free-string string) - (set-fret note string))) - ((eq? handle-negative 'recalculate) - (begin - (ly:warning (_ "Requested string for pitch requires negative fret: string ~a pitch ~a") string (note-pitch note)) - (ly:warning (_ "Ignoring string request.")) - (set! unassigned-notes (cons note unassigned-notes)))))))))) - 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) ;; end of determine-frets-and-strings + (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 (= (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)) + (eqv? digit 0)) + (if (eqv? 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 (and (>= this-fret 0) (integer? this-fret)) + (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 (= (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:event-warning + (list-ref notes (cdr pitch-entry)) + (_ "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)))) - (if (null? grob) - (placement-list->string-frets predefined-fretboard) - (create-fretboard context grob predefined-fretboard))))) + (if (null? predefined-fretboard) + (let ((string-frets + (determine-frets-and-strings + notes + strings-used + defined-fingers + (ly:context-property context 'minimumFret 0) + (ly:context-property context 'maximumFretStretch 4) + tunings))) + (if (null? grob) + string-frets + (create-fretboard + context grob (string-frets->placement-list + (filter (lambda (entry) + (car entry)) + string-frets) + string-count)))) + (if (null? grob) + (placement-list->string-frets predefined-fretboard) + (create-fretboard context grob predefined-fretboard))))) @@ -504,26 +583,26 @@ chords. Returns a placement-list." ;; The fret letter is taken from 'fretLabels if present (define-public (fret-letter-tablature-format context string-number fret-number) - (let ((labels (ly:context-property context 'fretLabels))) - (make-vcenter-markup - (cond - ((= 0 (length labels)) - (string (integer->char (+ fret-number (char->integer #\a))))) - ((and (<= 0 fret-number) (< fret-number (length labels))) - (list-ref labels fret-number)) - (else - (ly:warning (_ "No label for fret ~a (on string ~a); + (let ((labels (ly:context-property context 'fretLabels))) + (make-vcenter-markup + (cond + ((= 0 (length labels)) + (string (integer->char (+ fret-number (char->integer #\a))))) + ((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)) - "."))))) + fret-number string-number (length labels)) + "."))))) ;; Display the fret number as a number (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 +;; The 5-string banjo has got an extra string, the fifth (duh), which ;; starts at the fifth fret on the neck. Frets on the fifth string ;; are referred to relative to the other frets: ;; the "first fret" on the fifth string is really the sixth fret @@ -531,11 +610,11 @@ only ~a fret labels provided") ;; We solve this by defining a new fret-number-tablature function: (define-public (fret-number-tablature-format-banjo context string-number fret-number) - (make-vcenter-markup - (number->string (cond - ((and (> fret-number 0) (= string-number 5)) - (+ fret-number 5)) - (else fret-number))))) + (make-vcenter-markup + (number->string (cond + ((and (> fret-number 0) (= string-number 5)) + (+ fret-number 5)) + (else fret-number))))) ;; Tab note head staff position functions ;; @@ -544,31 +623,66 @@ only ~a fret labels provided") ;; lines (define-public (tablature-position-on-lines context string-number) - (let* ((string-tunings (ly:context-property context 'stringTunings)) - (string-count (length string-tunings)) - (string-one-topmost (ly:context-property context 'stringOneTopmost)) - (staff-line (- (* 2 string-number) string-count 1))) - (if string-one-topmost - (- staff-line) - staff-line))) + (let* ((string-tunings (ly:context-property context 'stringTunings)) + (string-count (length string-tunings)) + (string-one-topmost (ly:context-property context 'stringOneTopmost)) + (staff-line (- (* 2 string-number) string-count 1))) + (if string-one-topmost + (- staff-line) + staff-line))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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) (let ((bn (ly:context-property tr 'currentBarNumber))) (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) + (modulo-bar-number-visible n (modulo bn n))))) + +(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) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -578,3 +692,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)))