diff options
| author | Marc Hohl <marc@hohlart.de> | 2013-06-06 10:35:26 +0200 |
|---|---|---|
| committer | Marc Hohl <marc@hohlart.de> | 2013-06-06 10:35:26 +0200 |
| commit | 44dd3acc534e7a534f846810b481c3f603eaa92e (patch) | |
| tree | 25911b8bc86279cbf458577f2be52bb36fefb7ae | |
| parent | 467c4fe2943890bdcb760303de8107b69135014c (diff) | |
Apply scripts/auxiliar/fixscm.sh
87 files changed, 14696 insertions, 14696 deletions
diff --git a/scm/auto-beam.scm b/scm/auto-beam.scm index b77022f2fc..42387960ef 100644 --- a/scm/auto-beam.scm +++ b/scm/auto-beam.scm @@ -50,13 +50,13 @@ (ending-moments (cdr group-list) new-start base-moment))))) (define (larger-setting test-beam sorted-alist) - (if (null? sorted-alist) - '() - (let* ((first-key (caar sorted-alist)) - (first-moment (fraction->moment first-key))) - (if (moment<=? test-beam first-moment) - (car sorted-alist) - (larger-setting test-beam (cdr sorted-alist)))))) + (if (null? sorted-alist) + '() + (let* ((first-key (caar sorted-alist)) + (first-moment (fraction->moment first-key))) + (if (moment<=? test-beam first-moment) + (car sorted-alist) + (larger-setting test-beam (cdr sorted-alist)))))) (define (beat-end? moment beat-structure) (pair? (member moment beat-structure))) ;; member returns a list if found, not #t @@ -71,7 +71,7 @@ (let* ((base-moment (get 'baseMoment (ly:make-moment 1 4))) (measure-length (get 'measureLength (ly:make-moment 1 1))) (time-signature-fraction - (get 'timeSignatureFraction '(4 . 4))) + (get 'timeSignatureFraction '(4 . 4))) (beat-structure (get 'beatStructure '(1 1 1 1))) (beat-endings (ending-moments beat-structure 0 base-moment)) (exceptions (sort (assoc-get 'end @@ -82,8 +82,8 @@ (beam-half-measure (get 'beamHalfMeasure #t)) (type (moment->fraction test-beam)) (non-grace (ly:make-moment - (ly:moment-main-numerator measure-pos) - (ly:moment-main-denominator measure-pos))) + (ly:moment-main-numerator measure-pos) + (ly:moment-main-denominator measure-pos))) (pos (if (ly:moment<? non-grace ZERO-MOMENT) (ly:moment-add measure-length non-grace) non-grace)) @@ -98,15 +98,15 @@ (car default-rule) '())) (exception-grouping (if (null? type-grouping) - default-grouping - type-grouping)) + default-grouping + type-grouping)) (grouping-moment (if (null? type-grouping) (fraction->moment default-beat-length) test-beam)) (exception-moments (ending-moments - exception-grouping 0 grouping-moment))) + exception-grouping 0 grouping-moment))) - (if (= dir START) + (if (= dir START) ;; Start rules -- #t if beam is allowed to start (or beam-half-measure ;; Start anywhere, but option for mid-measure (not (equal? (ly:moment-add pos pos) measure-length)) diff --git a/scm/autochange.scm b/scm/autochange.scm index 14252e4b1d..b358c22b53 100644 --- a/scm/autochange.scm +++ b/scm/autochange.scm @@ -6,41 +6,41 @@ (define-public (make-autochange-music parser music) (define (generate-split-list change-moment event-list acc) (if (null? event-list) - acc - (let* ((now-tun (caar event-list)) - (evs (map car (cdar event-list))) - (now (car now-tun)) - (notes (filter (lambda (x) - (ly:in-event-class? x 'note-event)) - evs)) - (pitch (if (pair? notes) - (ly:event-property (car notes) 'pitch) - #f))) - ;; tail recursive. - (if (and pitch (not (= (ly:pitch-steps pitch) 0))) - (generate-split-list #f - (cdr event-list) - (cons (cons + acc + (let* ((now-tun (caar event-list)) + (evs (map car (cdar event-list))) + (now (car now-tun)) + (notes (filter (lambda (x) + (ly:in-event-class? x 'note-event)) + evs)) + (pitch (if (pair? notes) + (ly:event-property (car notes) 'pitch) + #f))) + ;; tail recursive. + (if (and pitch (not (= (ly:pitch-steps pitch) 0))) + (generate-split-list #f + (cdr event-list) + (cons (cons + + (if change-moment + change-moment + now) + (sign (ly:pitch-steps pitch))) acc)) + (generate-split-list + (if pitch #f now) + (cdr event-list) acc))))) - (if change-moment - change-moment - now) - (sign (ly:pitch-steps pitch))) acc)) - (generate-split-list - (if pitch #f now) - (cdr event-list) acc))))) - (let* ((m (make-music 'AutoChangeMusic)) - (m1 (make-non-relative-music (context-spec-music music 'Voice "one"))) - (context-list (recording-group-emulate music - (ly:parser-lookup parser 'partCombineListener))) - (evs (car context-list)) + (m1 (make-non-relative-music (context-spec-music music 'Voice "one"))) + (context-list (recording-group-emulate music + (ly:parser-lookup parser 'partCombineListener))) + (evs (car context-list)) (rev (reverse! (cdar context-list))) - (split (reverse! (generate-split-list - #f - rev - '()) - '()))) + (split (reverse! (generate-split-list + #f + rev + '()) + '()))) (set! (ly:music-property m 'element) music) (set! (ly:music-property m 'split-list) split) m)) diff --git a/scm/backend-library.scm b/scm/backend-library.scm index 0734a1a834..527e6fef95 100644 --- a/scm/backend-library.scm +++ b/scm/backend-library.scm @@ -16,25 +16,25 @@ ;;;; You should have received a copy of the GNU General Public License ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; backend helpers. (use-modules (scm ps-to-png) - (scm paper-system) - (ice-9 optargs)) + (scm paper-system) + (ice-9 optargs)) (define-public (ly:system command) (ly:debug (_ "Invoking `~a'...") (string-join command)) (let ((status (apply ly:spawn command))) (if (> status 0) - (begin - (ly:warning (_ "`~a' failed (~a)\n") command status) - ;; hmmm. what's the best failure option? - (throw 'ly-file-failed))))) + (begin + (ly:warning (_ "`~a' failed (~a)\n") command status) + ;; hmmm. what's the best failure option? + (throw 'ly-file-failed))))) (define-public (sanitize-command-option str) "Kill dubious shell quoting." - + (string-append "\"" (regexp-substitute/global #f "[^-_ 0-9,.a-zA-Z'\"\\]" str 'pre 'post) @@ -43,81 +43,81 @@ (define-public (search-executable names) (define (helper path lst) (if (null? (cdr lst)) - (car lst) - (if (search-path path (car lst)) (car lst) - (helper path (cdr lst))))) + (car lst) + (if (search-path path (car lst)) (car lst) + (helper path (cdr lst))))) (let ((path (parse-path (getenv "PATH")))) (helper path names))) (define-public (search-gs) - + ;; must be sure that we don't catch stuff from old GUBs. (search-executable '("gs"))) - + (define-public (postscript->pdf paper-width paper-height name) (let* ((pdf-name (string-append - (dir-basename name ".ps" ".eps") - ".pdf")) - (is-eps (string-match "\\.eps$" name)) - (*unspecified* (if #f #f)) - (cmd - (remove (lambda (x) (eq? x *unspecified*)) - (list - (search-gs) - (if (ly:get-option 'verbose) *unspecified* "-q") - (if (or (ly:get-option 'gs-load-fonts) - (ly:get-option 'gs-load-lily-fonts) - (eq? PLATFORM 'windows)) - "-dNOSAFER" - "-dSAFER") - - (if is-eps - "-dEPSCrop" - (ly:format "-dDEVICEWIDTHPOINTS=~$" paper-width)) - (if is-eps - *unspecified* - (ly:format "-dDEVICEHEIGHTPOINTS=~$" paper-height)) - "-dCompatibilityLevel=1.4" - "-dNOPAUSE" - "-dBATCH" - "-r1200" - "-sDEVICE=pdfwrite" - (string-append "-sOutputFile=" pdf-name) - "-c.setpdfwrite" - (string-append "-f" name))))) + (dir-basename name ".ps" ".eps") + ".pdf")) + (is-eps (string-match "\\.eps$" name)) + (*unspecified* (if #f #f)) + (cmd + (remove (lambda (x) (eq? x *unspecified*)) + (list + (search-gs) + (if (ly:get-option 'verbose) *unspecified* "-q") + (if (or (ly:get-option 'gs-load-fonts) + (ly:get-option 'gs-load-lily-fonts) + (eq? PLATFORM 'windows)) + "-dNOSAFER" + "-dSAFER") + + (if is-eps + "-dEPSCrop" + (ly:format "-dDEVICEWIDTHPOINTS=~$" paper-width)) + (if is-eps + *unspecified* + (ly:format "-dDEVICEHEIGHTPOINTS=~$" paper-height)) + "-dCompatibilityLevel=1.4" + "-dNOPAUSE" + "-dBATCH" + "-r1200" + "-sDEVICE=pdfwrite" + (string-append "-sOutputFile=" pdf-name) + "-c.setpdfwrite" + (string-append "-f" name))))) (ly:message (_ "Converting to `~a'...\n") pdf-name) (ly:system cmd))) (define-public (postscript->png resolution paper-width paper-height name) (let* ((verbose (ly:get-option 'verbose)) - (rename-page-1 #f)) + (rename-page-1 #f)) ;; Do not try to guess the name of the png file, ;; GS produces PNG files like BASE-page%d.png. (ly:message (_ "Converting to ~a...") "PNG") (make-ps-images name - #:resolution resolution - #:page-width paper-width - #:page-height paper-height - #:rename-page-1 rename-page-1 - #:be-verbose verbose - #:anti-alias-factor (ly:get-option 'anti-alias-factor) - #:pixmap-format (ly:get-option 'pixmap-format)) + #:resolution resolution + #:page-width paper-width + #:page-height paper-height + #:rename-page-1 rename-page-1 + #:be-verbose verbose + #:anti-alias-factor (ly:get-option 'anti-alias-factor) + #:pixmap-format (ly:get-option 'pixmap-format)) (ly:progress "\n"))) (define-public (postprocess-output paper-book module filename formats) (let* ((completed (completize-formats formats)) - (base (dir-basename filename ".ps" ".eps")) - (intermediate (remove (lambda (x) (member x formats)) completed))) + (base (dir-basename filename ".ps" ".eps")) + (intermediate (remove (lambda (x) (member x formats)) completed))) (for-each (lambda (f) - ((eval (string->symbol (format #f "convert-to-~a" f)) - module) paper-book filename)) completed) + ((eval (string->symbol (format #f "convert-to-~a" f)) + module) paper-book filename)) completed) (if (ly:get-option 'delete-intermediate-files) - (for-each (lambda (f) - (if (file-exists? f) (delete-file f))) - (map (lambda (x) (string-append base "." x)) intermediate))))) + (for-each (lambda (f) + (if (file-exists? f) (delete-file f))) + (map (lambda (x) (string-append base "." x)) intermediate))))) (define-public (completize-formats formats) (define new-fmts '()) @@ -126,8 +126,8 @@ (if (member "pdf" formats) (set! formats (cons "ps" formats))) (for-each (lambda (x) - (if (member x formats) (set! new-fmts (cons x new-fmts)))) - '("ps" "pdf" "png")) + (if (member x formats) (set! new-fmts (cons x new-fmts)))) + '("ps" "pdf" "png")) (uniq-list (reverse new-fmts))) (define (header-to-file file-name key value) @@ -135,13 +135,13 @@ (if (not (equal? "-" file-name)) (set! file-name (string-append file-name "." key))) (ly:message (_ "Writing header field `~a' to `~a'...") - key - (if (equal? "-" file-name) "<stdout>" file-name)) + key + (if (equal? "-" file-name) "<stdout>" file-name)) (if (equal? file-name "-") (display value) (let ((port (open-file file-name "w"))) - (display value port) - (close-port port))) + (display value port) + (close-port port))) (ly:progress "\n") "") @@ -152,10 +152,10 @@ string-append (module-map (lambda (sym var) - (let ((val (if (variable-bound? var) (variable-ref var) ""))) - (if (and (memq sym fields) (string? val)) - (header-to-file basename sym val)) - "")) + (let ((val (if (variable-bound? var) (variable-ref var) ""))) + (if (and (memq sym fields) (string? val)) + (header-to-file basename sym val)) + "")) scope))) (apply string-append (map output-scope scopes))) @@ -163,20 +163,20 @@ (let ((systems (ly:paper-book-systems book))) ;; skip booktitles. (if (and (not (ly:get-option 'include-book-title-preview)) - (pair? systems) - (ly:prob-property (car systems) 'is-book-title #f)) - (cdr systems) - systems))) + (pair? systems) + (ly:prob-property (car systems) 'is-book-title #f)) + (cdr systems) + systems))) (define-public (relevant-dump-systems systems) (let ((to-dump-systems '())) (for-each - (lambda (sys) - (if (or (paper-system-title? sys) - (not (pair? to-dump-systems)) - (paper-system-title? (car to-dump-systems))) - (set! to-dump-systems (cons sys to-dump-systems)))) - systems) + (lambda (sys) + (if (or (paper-system-title? sys) + (not (pair? to-dump-systems)) + (paper-system-title? (car to-dump-systems))) + (set! to-dump-systems (cons sys to-dump-systems)))) + systems) to-dump-systems)) (define missing-stencil-list '()) @@ -188,20 +188,20 @@ "")) (map (lambda (x) - (if (not (module-defined? output-module x)) - (begin - (module-define! output-module x - (lambda* (#:optional y . z) - (missing-stencil-expression x))) - (set! missing-stencil-list (append (list x) - missing-stencil-list))))) + (if (not (module-defined? output-module x)) + (begin + (module-define! output-module x + (lambda* (#:optional y . z) + (missing-stencil-expression x))) + (set! missing-stencil-list (append (list x) + missing-stencil-list))))) (ly:all-stencil-commands))) (define-public (remove-stencil-warnings output-module) (for-each - (lambda (x) - (module-remove! output-module x)) - missing-stencil-list)) + (lambda (x) + (module-remove! output-module x)) + missing-stencil-list)) (define (filter-out pred? lst) (filter (lambda (x) (not (pred? x))) lst)) @@ -211,8 +211,8 @@ or @code{#f}." (let ((match (regexp-exec (make-regexp "(.*)-([0-9]*)") font-name))) (if (regexp-match? match) - (cons (match:substring match 1) (match:substring match 2)) - (cons font-name-designsize #f)))) + (cons (match:substring match 1) (match:substring match 2)) + (cons font-name-designsize #f)))) ;; Example of a pango-physical-font ;; ("Emmentaler-11" "/home/janneke/vc/lilypond/out/share/lilypond/current/fonts/otf/emmentaler-11.otf" 0) @@ -229,8 +229,8 @@ or @code{#f}." (define (pango-font-name pango-font) (let ((pf-fonts (ly:pango-font-physical-fonts pango-font))) (if (pair? pf-fonts) - (pango-pf-font-name (car pf-fonts)) - ""))) + (pango-pf-font-name (car pf-fonts)) + ""))) (define-public (define-fonts paper define-font define-pango-pf) "Return a string of all fonts used in @var{paper}, invoking the functions @@ -238,33 +238,33 @@ or @code{#f}." definition." (let* ((font-list (ly:paper-fonts paper)) - (pango-fonts (filter ly:pango-font? font-list)) - (other-fonts (filter-out ly:pango-font? font-list)) - (other-font-names (map ly:font-name other-fonts)) - (pango-only-fonts - (filter-out (lambda (x) - (member (pango-font-name x) other-font-names)) - pango-fonts))) - - (define (font-load-command font) - (let* ((font-name (ly:font-name font)) - (designsize (ly:font-design-size font)) - (magnification (* (ly:font-magnification font))) - (ops (ly:output-def-lookup paper 'output-scale)) - (scaling (* ops magnification designsize))) - (if (equal? font-name "unknown") - (display (list font font-name))) - (define-font font font-name scaling))) - - (define (pango-font-load-command pango-font) - (let* ((pf-fonts (ly:pango-font-physical-fonts pango-font)) - (pango-pf (if (pair? pf-fonts) (car pf-fonts) '("" "" 0))) - (font-name (pango-pf-font-name pango-pf)) - (scaling (ly:output-def-lookup paper 'output-scale))) - (if (equal? font-name "unknown") - (display (list pango-font font-name))) - (define-pango-pf pango-pf font-name scaling))) + (pango-fonts (filter ly:pango-font? font-list)) + (other-fonts (filter-out ly:pango-font? font-list)) + (other-font-names (map ly:font-name other-fonts)) + (pango-only-fonts + (filter-out (lambda (x) + (member (pango-font-name x) other-font-names)) + pango-fonts))) - (string-append - (apply string-append (map font-load-command other-fonts)) - (apply string-append (map pango-font-load-command pango-only-fonts))))) + (define (font-load-command font) + (let* ((font-name (ly:font-name font)) + (designsize (ly:font-design-size font)) + (magnification (* (ly:font-magnification font))) + (ops (ly:output-def-lookup paper 'output-scale)) + (scaling (* ops magnification designsize))) + (if (equal? font-name "unknown") + (display (list font font-name))) + (define-font font font-name scaling))) + + (define (pango-font-load-command pango-font) + (let* ((pf-fonts (ly:pango-font-physical-fonts pango-font)) + (pango-pf (if (pair? pf-fonts) (car pf-fonts) '("" "" 0))) + (font-name (pango-pf-font-name pango-pf)) + (scaling (ly:output-def-lookup paper 'output-scale))) + (if (equal? font-name "unknown") + (display (list pango-font font-name))) + (define-pango-pf pango-pf font-name scaling))) + + (string-append + (apply string-append (map font-load-command other-fonts)) + (apply string-append (map pango-font-load-command pango-only-fonts))))) diff --git a/scm/bar-line.scm b/scm/bar-line.scm index e23ff8c0f2..809a08ca48 100644 --- a/scm/bar-line.scm +++ b/scm/bar-line.scm @@ -35,12 +35,12 @@ and the dimensions of the extent into account." (let ((blot-diameter (layout-blot-diameter grob)) (height (interval-length extent))) - (cond ((< thickness blot-diameter) thickness) - ((< height blot-diameter) height) - (else blot-diameter))) + (cond ((< thickness blot-diameter) thickness) + ((< height blot-diameter) height) + (else blot-diameter))) 0))) - blot)) + blot)) (define (get-span-glyph bar-glyph) "Get the corresponding span glyph from the @code{span-glyph-bar-alist}. @@ -48,12 +48,12 @@ Pad the string with @code{annotation-char}s to the length of the @var{bar-glyph} string." (let ((span-glyph (assoc-get bar-glyph span-bar-glyph-alist bar-glyph))) - (if (string? span-glyph) - (set! span-glyph (string-pad-right + (if (string? span-glyph) + (set! span-glyph (string-pad-right span-glyph (string-length bar-glyph) replacement-char))) - span-glyph)) + span-glyph)) (define (get-staff-symbol grob) "Return the staff symbol corresponding to Grob @var{grob}." @@ -66,51 +66,51 @@ Pad the string with @code{annotation-char}s to the length of the (let* ((layout (ly:grob-layout grob)) (blot-diameter (ly:output-def-lookup layout 'blot-diameter))) - blot-diameter)) + blot-diameter)) (define (staff-symbol-line-count staff) "Get or compute the number of lines of staff @var{staff}." (let ((line-count 0)) - (if (ly:grob? staff) - (let ((line-pos (ly:grob-property staff 'line-positions '()))) + (if (ly:grob? staff) + (let ((line-pos (ly:grob-property staff 'line-positions '()))) - (set! line-count (if (pair? line-pos) - (length line-pos) - (ly:grob-property staff 'line-count 0))))) + (set! line-count (if (pair? line-pos) + (length line-pos) + (ly:grob-property staff 'line-count 0))))) - line-count)) + line-count)) (define (staff-symbol-line-span grob) (let ((line-pos (ly:grob-property grob 'line-positions '())) (iv (cons 0.0 0.0))) - (if (pair? line-pos) - (begin - (set! iv (cons (car line-pos) (car line-pos))) - (map (lambda (x) - (set! iv (cons (min (car iv) x) - (max (cdr iv) x)))) - (cdr line-pos))) + (if (pair? line-pos) + (begin + (set! iv (cons (car line-pos) (car line-pos))) + (map (lambda (x) + (set! iv (cons (min (car iv) x) + (max (cdr iv) x)))) + (cdr line-pos))) - (let ((line-count (ly:grob-property grob 'line-count 0))) + (let ((line-count (ly:grob-property grob 'line-count 0))) - (set! iv (cons (- 1 line-count) - (- line-count 1))))) - iv)) + (set! iv (cons (- 1 line-count) + (- line-count 1))))) + iv)) (define (staff-symbol-line-positions grob) "Get or compute the @code{'line-positions} list from @var{grob}." (let ((line-pos (ly:grob-property grob 'line-positions '()))) - (if (not (pair? line-pos)) - (let* ((line-count (ly:grob-property grob 'line-count 0)) - (height (- line-count 1.0))) + (if (not (pair? line-pos)) + (let* ((line-count (ly:grob-property grob 'line-count 0)) + (height (- line-count 1.0))) - (set! line-pos (map (lambda (x) - (- height (* x 2))) - (iota line-count))))) - line-pos)) + (set! line-pos (map (lambda (x) + (- height (* x 2))) + (iota line-count))))) + line-pos)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; internal helper functions @@ -128,46 +128,46 @@ mandatory to the procedures stored in @code{bar-glyph-print-procedures}." (let ((proc (assoc-get glyph bar-glyph-print-procedures)) (stencil empty-stencil)) - (if (procedure? proc) - (set! stencil (proc grob extent)) - (ly:warning (_ "Bar glyph ~a not known. Ignoring.") glyph)) - stencil)) + (if (procedure? proc) + (set! stencil (proc grob extent)) + (ly:warning (_ "Bar glyph ~a not known. Ignoring.") glyph)) + stencil)) (define (string->string-list str) "Convert a string into a list of strings with length 1. @code{"aBc"} will be converted to @code{("a" "B" "c")}. An empty string will be converted to a list containing @code{""}." - (if (and (string? str) - (not (zero? (string-length str)))) - (map (lambda (s) - (string s)) - (string->list str)) - (list ""))) +(if (and (string? str) + (not (zero? (string-length str)))) + (map (lambda (s) + (string s)) + (string->list str)) + (list ""))) (define (strip-string-annotation str) "Strip annotations starting with and including the annotation char from string @var{str}." (let ((pos (string-index str annotation-char))) - (if pos - (substring str 0 pos) - str))) + (if pos + (substring str 0 pos) + str))) (define (check-for-annotation str) "Check whether the annotation char is present in string @var{str}." (if (string? str) (if (string-index str annotation-char) (ly:warning - (_ "Annotation '~a' is allowed in the first argument of a bar line definition only.") - str)))) + (_ "Annotation '~a' is allowed in the first argument of a bar line definition only.") + str)))) (define (check-for-replacement str) "Check whether the replacement char is present in string @var{str}." (if (string? str) (if (string-index str replacement-char) (ly:warning - (_ "Replacement '~a' is allowed in the last argument of a bar line definition only.") - str)))) + (_ "Replacement '~a' is allowed in the last argument of a bar line definition only.") + str)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; functions used by external routines @@ -179,18 +179,18 @@ annotation char from string @var{str}." (last-pos (1- (length sorted-elts))) (idx 0)) - (map (lambda (g) - (ly:grob-set-property! - g - 'has-span-bar - (cons (if (eq? idx last-pos) - #f - grob) - (if (zero? idx) - #f - grob))) - (set! idx (1+ idx))) - sorted-elts))) + (map (lambda (g) + (ly:grob-set-property! + g + 'has-span-bar + (cons (if (eq? idx last-pos) + #f + grob) + (if (zero? idx) + #f + grob))) + (set! idx (1+ idx))) + sorted-elts))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Line break decisions. @@ -227,10 +227,10 @@ is not used within the routine." (if (or (not (string? glyph)) (> (string-length glyph) 1)) (ly:warning - (_ "add-bar-glyph-print-procedure: glyph '~a' has to be a single ASCII character.") - glyph) + (_ "add-bar-glyph-print-procedure: glyph '~a' has to be a single ASCII character.") + glyph) (set! bar-glyph-print-procedures - (acons glyph proc bar-glyph-print-procedures)))) + (acons glyph proc bar-glyph-print-procedures)))) (define-session bar-glyph-print-procedures `()) @@ -253,9 +253,9 @@ is not used within the routine." (blot (calc-blot thickness extent grob)) (extent (bar-line::widen-bar-extent-on-span grob extent))) - (ly:round-filled-box (cons 0 thickness) - extent - blot))) + (ly:round-filled-box (cons 0 thickness) + extent + blot))) (define (make-thick-bar-line grob extent) "Draw a thick bar line." @@ -265,9 +265,9 @@ is not used within the routine." (blot (calc-blot thickness extent grob)) (extent (bar-line::widen-bar-extent-on-span grob extent))) - (ly:round-filled-box (cons 0 thickness) - extent - blot))) + (ly:round-filled-box (cons 0 thickness) + extent + blot))) (define (make-tick-bar-line grob extent) "Draw a tick bar line." @@ -276,9 +276,9 @@ is not used within the routine." (height (interval-end extent)) (blot (calc-blot staff-line-thickness extent grob))) - (ly:round-filled-box (cons 0 staff-line-thickness) - (cons (- height half-staff) (+ height half-staff)) - blot))) + (ly:round-filled-box (cons 0 staff-line-thickness) + (cons (- height half-staff) (+ height half-staff)) + blot))) (define (make-colon-bar-line grob extent) "Draw repeat dots." @@ -366,19 +366,19 @@ is not used within the routine." (- 0.5 correction)))) (counting (interval-length (cons i e))) (stil-list (map - (lambda (x) - (ly:stencil-translate-axis - dot (+ x correction) Y)) - (iota counting i 1)))) + (lambda (x) + (ly:stencil-translate-axis + dot (+ x correction) Y)) + (iota counting i 1)))) - (define (add-stencils! stil l) - (if (null? l) - stil - (if (null? (cdr l)) - (ly:stencil-add stil (car l)) - (add-stencils! (ly:stencil-add stil (car l)) (cdr l))))) + (define (add-stencils! stil l) + (if (null? l) + stil + (if (null? (cdr l)) + (ly:stencil-add stil (car l)) + (add-stencils! (ly:stencil-add stil (car l)) (cdr l))))) - (add-stencils! empty-stencil stil-list))) + (add-stencils! empty-stencil stil-list))) (define (make-dashed-bar-line grob extent) "Draw a dashed bar line." @@ -391,48 +391,48 @@ is not used within the routine." (dash-size (- 1.0 (ly:grob-property grob 'gap 0.3))) (line-count (staff-symbol-line-count staff-symbol))) - (if (< (abs (+ line-thickness - (* (1- line-count) staff-space) - (- height))) - 0.1) - (let ((blot (layout-blot-diameter grob)) - (half-space (/ staff-space 2.0)) - (half-thick (/ line-thickness 2.0)) - (stencil empty-stencil)) - - (map (lambda (i) - (let ((top-y (min (* (+ i dash-size) half-space) - (+ (* (1- line-count) half-space) - half-thick))) - (bot-y (max (* (- i dash-size) half-space) - (- 0 (* (1- line-count) half-space) - half-thick)))) - - (set! stencil - (ly:stencil-add - stencil - (ly:round-filled-box (cons 0 thickness) - (cons bot-y top-y) - blot))))) - (iota line-count (1- line-count) (- 2))) - stencil) - (let* ((dashes (/ height staff-space)) - (total-dash-size (/ height dashes)) - (factor (/ (- dash-size thickness) staff-space)) - (stencil (ly:stencil-translate-axis - (ly:make-stencil (list 'dashed-line - thickness - (* factor total-dash-size) - (* (- 1 factor) total-dash-size) - 0 - height - (* factor total-dash-size 0.5)) - (cons (/ thickness -2) (/ thickness 2)) - (cons 0 height)) - (interval-start extent) - Y))) - - (ly:stencil-translate-axis stencil (/ thickness 2) X))))) + (if (< (abs (+ line-thickness + (* (1- line-count) staff-space) + (- height))) + 0.1) + (let ((blot (layout-blot-diameter grob)) + (half-space (/ staff-space 2.0)) + (half-thick (/ line-thickness 2.0)) + (stencil empty-stencil)) + + (map (lambda (i) + (let ((top-y (min (* (+ i dash-size) half-space) + (+ (* (1- line-count) half-space) + half-thick))) + (bot-y (max (* (- i dash-size) half-space) + (- 0 (* (1- line-count) half-space) + half-thick)))) + + (set! stencil + (ly:stencil-add + stencil + (ly:round-filled-box (cons 0 thickness) + (cons bot-y top-y) + blot))))) + (iota line-count (1- line-count) (- 2))) + stencil) + (let* ((dashes (/ height staff-space)) + (total-dash-size (/ height dashes)) + (factor (/ (- dash-size thickness) staff-space)) + (stencil (ly:stencil-translate-axis + (ly:make-stencil (list 'dashed-line + thickness + (* factor total-dash-size) + (* (- 1 factor) total-dash-size) + 0 + height + (* factor total-dash-size 0.5)) + (cons (/ thickness -2) (/ thickness 2)) + (cons 0 height)) + (interval-start extent) + Y))) + + (ly:stencil-translate-axis stencil (/ thickness 2) X))))) (define ((make-segno-bar-line show-segno) grob extent) @@ -443,37 +443,37 @@ draws the span bar variant, i.e. without the segno sign." (thinkern (* (ly:grob-property grob 'thin-kern 1) line-thickness)) (thin-stil (make-simple-bar-line grob extent)) (double-line-stil (ly:stencil-combine-at-edge - thin-stil - X - LEFT - thin-stil - thinkern)) + thin-stil + X + LEFT + thin-stil + thinkern)) (segno (ly:font-get-glyph (ly:grob-default-font grob) "scripts.varsegno")) (stencil (ly:stencil-add - (if show-segno - segno - (ly:make-stencil - "" - (ly:stencil-extent segno X) - (cons 0 0))) - (ly:stencil-translate-axis - double-line-stil - (* 1/2 thinkern) - X)))) - - stencil)) + (if show-segno + segno + (ly:make-stencil + "" + (ly:stencil-extent segno X) + (cons 0 0))) + (ly:stencil-translate-axis + double-line-stil + (* 1/2 thinkern) + X)))) + + stencil)) (define (make-kievan-bar-line grob extent) "Draw a kievan bar line." (let* ((font (ly:grob-default-font grob)) (stencil (stencil-whiteout - (ly:font-get-glyph font "scripts.barline.kievan")))) + (ly:font-get-glyph font "scripts.barline.kievan")))) - ;; the kievan bar line has no staff lines underneath, - ;; so we whiteout them and move the grob to a higher layer - (ly:grob-set-property! grob 'layer 1) - stencil)) + ;; the kievan bar line has no staff lines underneath, + ;; so we whiteout them and move the grob to a higher layer + (ly:grob-set-property! grob 'layer 1) + stencil)) (define ((make-bracket-bar-line dir) grob extent) "Draw a bracket-style bar line. If @var{dir} is set to @code{LEFT}, the @@ -489,20 +489,20 @@ opening bracket will be drawn, for @code{RIGHT} we get the closing bracket." (cons 0 0) (ly:stencil-extent brackettips-up Y))) (tip-down-stil (ly:make-stencil (ly:stencil-expr brackettips-down) - (cons 0 0) - (ly:stencil-extent brackettips-down Y))) + (cons 0 0) + (ly:stencil-extent brackettips-down Y))) (stencil (ly:stencil-add - thick-stil - (ly:stencil-translate-axis tip-up-stil - (interval-end extent) - Y) - (ly:stencil-translate-axis tip-down-stil - (interval-start extent) - Y)))) - - (if (eq? dir LEFT) - stencil - (ly:stencil-scale stencil -1 1)))) + thick-stil + (ly:stencil-translate-axis tip-up-stil + (interval-end extent) + Y) + (ly:stencil-translate-axis tip-down-stil + (interval-start extent) + Y)))) + + (if (eq? dir LEFT) + stencil + (ly:stencil-scale stencil -1 1)))) (define ((make-spacer-bar-line glyph) grob extent) "Draw an invisible bar line which has the same dimensions as the one @@ -510,7 +510,7 @@ drawn by the procedure associated with glyph @var{glyph}." (let* ((stil (glyph->stencil glyph grob extent)) (stil-x-extent (ly:stencil-extent stil X))) - (ly:make-stencil "" stil-x-extent extent))) + (ly:make-stencil "" stil-x-extent extent))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; bar line callbacks @@ -519,36 +519,36 @@ drawn by the procedure associated with glyph @var{glyph}." (let ((staff-symbol (get-staff-symbol grob)) (staff-extent (cons 0 0))) - (if (ly:grob? staff-symbol) - (let ((bar-line-color (ly:grob-property grob 'color)) - (staff-color (ly:grob-property staff-symbol 'color)) - (half-staff-line-thickness (/ (ly:staff-symbol-line-thickness grob) 2)) - (staff-space (ly:staff-symbol-staff-space grob))) - - (set! staff-extent (ly:staff-symbol::height staff-symbol)) - - (if (zero? staff-space) - (set! staff-space 1.0)) - - (if (< (interval-length staff-extent) staff-space) - ;; staff is too small (perhaps consists of a single line); - ;; extend the bar line to make it visible - (set! staff-extent - (interval-widen staff-extent staff-space)) - ;; Due to rounding problems, bar lines extending to the outermost edges - ;; of the staff lines appear wrongly in on-screen display - ;; (and, to a lesser extent, in print) - they stick out a pixel. - ;; The solution is to extend bar lines only to the middle - ;; of the staff line - unless they have different colors, - ;; when it would be undesirable. - ;; - ;; This reduction should not influence whether the bar is to be - ;; expanded later, so length is not updated on purpose. - (if (eq? bar-line-color staff-color) - (set! staff-extent - (interval-widen staff-extent - (- half-staff-line-thickness))))))) - staff-extent)) + (if (ly:grob? staff-symbol) + (let ((bar-line-color (ly:grob-property grob 'color)) + (staff-color (ly:grob-property staff-symbol 'color)) + (half-staff-line-thickness (/ (ly:staff-symbol-line-thickness grob) 2)) + (staff-space (ly:staff-symbol-staff-space grob))) + + (set! staff-extent (ly:staff-symbol::height staff-symbol)) + + (if (zero? staff-space) + (set! staff-space 1.0)) + + (if (< (interval-length staff-extent) staff-space) + ;; staff is too small (perhaps consists of a single line); + ;; extend the bar line to make it visible + (set! staff-extent + (interval-widen staff-extent staff-space)) + ;; Due to rounding problems, bar lines extending to the outermost edges + ;; of the staff lines appear wrongly in on-screen display + ;; (and, to a lesser extent, in print) - they stick out a pixel. + ;; The solution is to extend bar lines only to the middle + ;; of the staff line - unless they have different colors, + ;; when it would be undesirable. + ;; + ;; This reduction should not influence whether the bar is to be + ;; expanded later, so length is not updated on purpose. + (if (eq? bar-line-color staff-color) + (set! staff-extent + (interval-widen staff-extent + (- half-staff-line-thickness))))))) + staff-extent)) ;; this function may come in handy when defining new bar line glyphs, so ;; we make it public. @@ -559,23 +559,23 @@ drawn by the procedure associated with glyph @var{glyph}." (let ((staff-symbol (get-staff-symbol grob)) (has-span-bar (ly:grob-property grob 'has-span-bar #f))) - (if (and (ly:grob? staff-symbol) - (pair? has-span-bar)) - (let ((bar-line-color (ly:grob-property grob 'color)) - (staff-color (ly:grob-property staff-symbol 'color)) - (half-staff-line-thickness (/ (ly:staff-symbol-line-thickness grob) 2))) - (if (eq? bar-line-color staff-color) - ;; if the colors are equal, ly:bar-line::calc-bar-extent has - ;; shortened the bar line extent by a half-staff-line-thickness - ;; this is reverted on the interval bounds where span bars appear: - (begin - (and (ly:grob? (car has-span-bar)) - (set! extent (cons (- (car extent) half-staff-line-thickness) - (cdr extent)))) - (and (ly:grob? (cdr has-span-bar)) - (set! extent (cons (car extent) - (+ (cdr extent) half-staff-line-thickness)))))))) - extent)) + (if (and (ly:grob? staff-symbol) + (pair? has-span-bar)) + (let ((bar-line-color (ly:grob-property grob 'color)) + (staff-color (ly:grob-property staff-symbol 'color)) + (half-staff-line-thickness (/ (ly:staff-symbol-line-thickness grob) 2))) + (if (eq? bar-line-color staff-color) + ;; if the colors are equal, ly:bar-line::calc-bar-extent has + ;; shortened the bar line extent by a half-staff-line-thickness + ;; this is reverted on the interval bounds where span bars appear: + (begin + (and (ly:grob? (car has-span-bar)) + (set! extent (cons (- (car extent) half-staff-line-thickness) + (cdr extent)))) + (and (ly:grob? (cdr has-span-bar)) + (set! extent (cons (car extent) + (+ (cdr extent) half-staff-line-thickness)))))))) + extent)) (define (bar-line::bar-y-extent grob refpoint) "Compute the y-extent of the bar line relative to @var{refpoint}." @@ -583,24 +583,24 @@ drawn by the procedure associated with glyph @var{glyph}." (rel-y (ly:grob-relative-coordinate grob refpoint Y)) (y-extent (coord-translate extent rel-y))) - y-extent)) + y-extent)) (define-public (ly:bar-line::print grob) "The print routine for bar lines." (let ((glyph-name (ly:grob-property grob 'glyph-name)) (extent (ly:grob-property grob 'bar-extent '(0 . 0)))) - (if (and glyph-name - (> (interval-length extent) 0)) - (bar-line::compound-bar-line grob glyph-name extent) - #f))) + (if (and glyph-name + (> (interval-length extent) 0)) + (bar-line::compound-bar-line grob glyph-name extent) + #f))) (define-public (bar-line::compound-bar-line grob bar-glyph extent) "Build the bar line stencil." (let* ((line-thickness (layout-line-thickness grob)) (kern (* (ly:grob-property grob 'kern 1) line-thickness)) (bar-glyph-list (string->string-list - (strip-string-annotation bar-glyph))) + (strip-string-annotation bar-glyph))) (span-glyph (get-span-glyph bar-glyph)) (span-glyph-list (string->string-list span-glyph)) (neg-stencil empty-stencil) @@ -608,53 +608,53 @@ drawn by the procedure associated with glyph @var{glyph}." (is-first-neg-stencil #t) (is-first-stencil #t)) - ;; We build up two separate stencils first: - ;; (1) the neg-stencil is built from all glyphs that have - ;; a replacement-char in the span bar - ;; (2) the main stencil is built from all remaining glyphs - ;; - ;; Afterwards the neg-stencil is attached left to the - ;; stencil; this ensures that the main stencil starts - ;; at x = 0. - ;; - ;; For both routines holds: - ;; we stack the stencils obtained by the corresponding - ;; single glyphs with spacing 'kern' except for the - ;; first stencil - ;; (Thanks to Harm who came up with this idea!) - (for-each (lambda (bar span) - (if (and (string=? span (string replacement-char)) - is-first-stencil) - (begin - (set! neg-stencil - (ly:stencil-combine-at-edge - neg-stencil - X - RIGHT - (glyph->stencil bar grob extent) - (if is-first-neg-stencil 0 kern))) - (set! is-first-neg-stencil #f)) - (begin - (set! stencil - (ly:stencil-combine-at-edge - stencil - X - RIGHT - (glyph->stencil bar grob extent) - (if is-first-stencil 0 kern))) - (set! is-first-stencil #f)))) - bar-glyph-list span-glyph-list) - ;; if we have a non-empty neg-stencil, - ;; we attach it to the left side of the stencil - (and (not is-first-neg-stencil) - (set! stencil - (ly:stencil-combine-at-edge - stencil - X - LEFT - neg-stencil - kern))) - stencil)) + ;; We build up two separate stencils first: + ;; (1) the neg-stencil is built from all glyphs that have + ;; a replacement-char in the span bar + ;; (2) the main stencil is built from all remaining glyphs + ;; + ;; Afterwards the neg-stencil is attached left to the + ;; stencil; this ensures that the main stencil starts + ;; at x = 0. + ;; + ;; For both routines holds: + ;; we stack the stencils obtained by the corresponding + ;; single glyphs with spacing 'kern' except for the + ;; first stencil + ;; (Thanks to Harm who came up with this idea!) + (for-each (lambda (bar span) + (if (and (string=? span (string replacement-char)) + is-first-stencil) + (begin + (set! neg-stencil + (ly:stencil-combine-at-edge + neg-stencil + X + RIGHT + (glyph->stencil bar grob extent) + (if is-first-neg-stencil 0 kern))) + (set! is-first-neg-stencil #f)) + (begin + (set! stencil + (ly:stencil-combine-at-edge + stencil + X + RIGHT + (glyph->stencil bar grob extent) + (if is-first-stencil 0 kern))) + (set! is-first-stencil #f)))) + bar-glyph-list span-glyph-list) + ;; if we have a non-empty neg-stencil, + ;; we attach it to the left side of the stencil + (and (not is-first-neg-stencil) + (set! stencil + (ly:stencil-combine-at-edge + stencil + X + LEFT + neg-stencil + kern))) + stencil)) (define-public (ly:bar-line::calc-anchor grob) "Calculate the anchor position of a bar line. The anchor is used for @@ -665,22 +665,22 @@ the correct placement of bar numbers etc." (x-extent (ly:grob-extent grob grob X)) (anchor 0.0)) - (and (> (interval-length x-extent) 0) - (if (or (= (length bar-glyph-list) 1) - (string=? bar-glyph span-glyph) - (string=? span-glyph "")) - ;; We use the x-extent of the stencil if either - ;; - we have a single bar-glyph - ;; - bar-glyph and span-glyph are identical - ;; - we have no span-glyph - (set! anchor (interval-center x-extent)) - ;; If the conditions above do not hold,the anchor is the - ;; center of the corresponding span bar stencil extent - (set! anchor (interval-center - (ly:stencil-extent - (span-bar::compound-bar-line grob bar-glyph dummy-extent) - X))))) - anchor)) + (and (> (interval-length x-extent) 0) + (if (or (= (length bar-glyph-list) 1) + (string=? bar-glyph span-glyph) + (string=? span-glyph "")) + ;; We use the x-extent of the stencil if either + ;; - we have a single bar-glyph + ;; - bar-glyph and span-glyph are identical + ;; - we have no span-glyph + (set! anchor (interval-center x-extent)) + ;; If the conditions above do not hold,the anchor is the + ;; center of the corresponding span bar stencil extent + (set! anchor (interval-center + (ly:stencil-extent + (span-bar::compound-bar-line grob bar-glyph dummy-extent) + X))))) + anchor)) (define-public (bar-line::calc-glyph-name grob) "Determine the @code{glyph-name} of the bar line depending on the @@ -692,9 +692,9 @@ line break status." glyph (if (and result (string? (index-cell result dir))) - (index-cell result dir) - #f)))) - glyph-name)) + (index-cell result dir) + #f)))) + glyph-name)) (define-public (bar-line::calc-break-visibility grob) "Calculate the visibility of a bar line at line breaks." @@ -716,85 +716,85 @@ The corresponding SpanBar glyph is computed within (pos (1- (ly:grob-array-length elts))) (glyph-name '())) - (while (and (eq? glyph-name '()) - (> pos -1)) - (begin (set! glyph-name - (ly:grob-property (ly:grob-array-ref elts pos) - 'glyph-name)) - (set! pos (1- pos)))) - (if (eq? glyph-name '()) - (begin (ly:grob-suicide! grob) - (set! glyph-name ""))) - glyph-name)) + (while (and (eq? glyph-name '()) + (> pos -1)) + (begin (set! glyph-name + (ly:grob-property (ly:grob-array-ref elts pos) + 'glyph-name)) + (set! pos (1- pos)))) + (if (eq? glyph-name '()) + (begin (ly:grob-suicide! grob) + (set! glyph-name ""))) + glyph-name)) (define-public (ly:span-bar::width grob) "Compute the width of the SpanBar stencil." (let ((width (cons 0 0))) - (if (grob::is-live? grob) - (let* ((glyph-name (ly:grob-property grob 'glyph-name)) - (stencil (span-bar::compound-bar-line grob - glyph-name - dummy-extent))) + (if (grob::is-live? grob) + (let* ((glyph-name (ly:grob-property grob 'glyph-name)) + (stencil (span-bar::compound-bar-line grob + glyph-name + dummy-extent))) - (set! width (ly:stencil-extent stencil X)))) - width)) + (set! width (ly:stencil-extent stencil X)))) + width)) (define-public (ly:span-bar::before-line-breaking grob) "A dummy callback that kills the Grob @var{grob} if it contains no elements." (let ((elts (ly:grob-object grob 'elements))) - (if (zero? (ly:grob-array-length elts)) - (ly:grob-suicide! grob)))) + (if (zero? (ly:grob-array-length elts)) + (ly:grob-suicide! grob)))) (define-public (span-bar::compound-bar-line grob bar-glyph extent) "Build the stencil of the span bar." (let* ((line-thickness (layout-line-thickness grob)) (kern (* (ly:grob-property grob 'kern 1) line-thickness)) (bar-glyph-list (string->string-list - (strip-string-annotation bar-glyph))) + (strip-string-annotation bar-glyph))) (span-glyph (assoc-get bar-glyph span-bar-glyph-alist 'undefined)) (stencil empty-stencil)) - (if (string? span-glyph) - (let ((span-glyph-list (string->string-list span-glyph)) - (is-first-stencil #t)) - - (for-each (lambda (bar span) - ;; the stencil stack routine is similar to the one - ;; used in bar-line::compound-bar-line, but here, - ;; leading replacement-chars are discarded. - (if (not (and (string=? span (string replacement-char)) - is-first-stencil)) - (begin - (set! stencil - (ly:stencil-combine-at-edge - stencil - X - RIGHT - ;; if the current glyph is the replacement-char, - ;; we take the corresponding glyph from the - ;; bar-glyph-list and insert an empty stencil - ;; with the appropriate width. - ;; (this method would fail if the bar-glyph-list - ;; were shorter than the span-glyph-list, - ;; but this makes hardly any sense from a - ;; typographical point of view - (if (string=? span (string replacement-char)) - ((make-spacer-bar-line bar) grob extent) - (glyph->stencil span grob extent)) - (if is-first-stencil 0 kern))) - (set! is-first-stencil #f)))) - bar-glyph-list span-glyph-list)) - ;; if span-glyph is not a string, it may be #f or 'undefined; - ;; the latter signals that the span bar for the current bar-glyph - ;; is undefined, so we raise a warning. - (if (eq? span-glyph 'undefined) - (ly:warning - (_ "No span bar glyph defined for bar glyph '~a'; ignoring.") - bar-glyph))) - stencil)) + (if (string? span-glyph) + (let ((span-glyph-list (string->string-list span-glyph)) + (is-first-stencil #t)) + + (for-each (lambda (bar span) + ;; the stencil stack routine is similar to the one + ;; used in bar-line::compound-bar-line, but here, + ;; leading replacement-chars are discarded. + (if (not (and (string=? span (string replacement-char)) + is-first-stencil)) + (begin + (set! stencil + (ly:stencil-combine-at-edge + stencil + X + RIGHT + ;; if the current glyph is the replacement-char, + ;; we take the corresponding glyph from the + ;; bar-glyph-list and insert an empty stencil + ;; with the appropriate width. + ;; (this method would fail if the bar-glyph-list + ;; were shorter than the span-glyph-list, + ;; but this makes hardly any sense from a + ;; typographical point of view + (if (string=? span (string replacement-char)) + ((make-spacer-bar-line bar) grob extent) + (glyph->stencil span grob extent)) + (if is-first-stencil 0 kern))) + (set! is-first-stencil #f)))) + bar-glyph-list span-glyph-list)) + ;; if span-glyph is not a string, it may be #f or 'undefined; + ;; the latter signals that the span bar for the current bar-glyph + ;; is undefined, so we raise a warning. + (if (eq? span-glyph 'undefined) + (ly:warning + (_ "No span bar glyph defined for bar glyph '~a'; ignoring.") + bar-glyph))) + stencil)) ;; The method used in the following routine depends on bar_engraver ;; not being removed from staff context. If bar_engraver is removed, @@ -815,72 +815,72 @@ no elements." (bar-glyph (ly:grob-property grob 'glyph-name)) (span-bar empty-stencil)) - (if (string? bar-glyph) - (let ((extents '()) - (make-span-bars '()) - (model-bar #f)) - - ;; we compute the extents of each system and store them - ;; in a list; dito for the 'allow-span-bar property. - ;; model-bar takes the bar grob, if given. - (map (lambda (bar) - (let ((ext (bar-line::bar-y-extent bar refp)) - (staff-symbol (ly:grob-object bar 'staff-symbol))) - - (if (ly:grob? staff-symbol) - (let ((refp-extent (ly:grob-extent staff-symbol refp Y))) - - (set! ext (interval-union ext refp-extent)) - - (if (> (interval-length ext) 0) - (begin - (set! extents (append extents (list ext))) - (set! model-bar bar) - (set! make-span-bars - (append make-span-bars - (list (ly:grob-property - bar - 'allow-span-bar - #t)))))))))) - elts) - ;; if there is no bar grob, we use the callback argument - (if (not model-bar) - (set! model-bar grob)) - ;; we discard the first entry in make-span-bars, - ;; because its corresponding bar line is the - ;; uppermost and therefore not connected to - ;; another bar line - (if (pair? make-span-bars) - (set! make-span-bars (cdr make-span-bars))) - ;; the span bar reaches from the lower end of the upper staff - ;; to the upper end of the lower staff - when allow-span-bar is #t - (reduce (lambda (curr prev) - (let ((span-extent (cons 0 0)) - (allow-span-bar (car make-span-bars))) - - (set! make-span-bars (cdr make-span-bars)) - (if (> (interval-length prev) 0) - (begin - (set! span-extent (cons (cdr prev) - (car curr))) - ;; draw the span bar only when the staff lines - ;; don't overlap and allow-span-bar is #t: - (and (> (interval-length span-extent) 0) - allow-span-bar - (set! span-bar - (ly:stencil-add - span-bar - (span-bar::compound-bar-line - model-bar - bar-glyph - span-extent)))))) - curr)) - "" extents) - (set! span-bar (ly:stencil-translate-axis - span-bar - (- (ly:grob-relative-coordinate grob refp Y)) - Y)))) - span-bar)) + (if (string? bar-glyph) + (let ((extents '()) + (make-span-bars '()) + (model-bar #f)) + + ;; we compute the extents of each system and store them + ;; in a list; dito for the 'allow-span-bar property. + ;; model-bar takes the bar grob, if given. + (map (lambda (bar) + (let ((ext (bar-line::bar-y-extent bar refp)) + (staff-symbol (ly:grob-object bar 'staff-symbol))) + + (if (ly:grob? staff-symbol) + (let ((refp-extent (ly:grob-extent staff-symbol refp Y))) + + (set! ext (interval-union ext refp-extent)) + + (if (> (interval-length ext) 0) + (begin + (set! extents (append extents (list ext))) + (set! model-bar bar) + (set! make-span-bars + (append make-span-bars + (list (ly:grob-property + bar + 'allow-span-bar + #t)))))))))) + elts) + ;; if there is no bar grob, we use the callback argument + (if (not model-bar) + (set! model-bar grob)) + ;; we discard the first entry in make-span-bars, + ;; because its corresponding bar line is the + ;; uppermost and therefore not connected to + ;; another bar line + (if (pair? make-span-bars) + (set! make-span-bars (cdr make-span-bars))) + ;; the span bar reaches from the lower end of the upper staff + ;; to the upper end of the lower staff - when allow-span-bar is #t + (reduce (lambda (curr prev) + (let ((span-extent (cons 0 0)) + (allow-span-bar (car make-span-bars))) + + (set! make-span-bars (cdr make-span-bars)) + (if (> (interval-length prev) 0) + (begin + (set! span-extent (cons (cdr prev) + (car curr))) + ;; draw the span bar only when the staff lines + ;; don't overlap and allow-span-bar is #t: + (and (> (interval-length span-extent) 0) + allow-span-bar + (set! span-bar + (ly:stencil-add + span-bar + (span-bar::compound-bar-line + model-bar + bar-glyph + span-extent)))))) + curr)) + "" extents) + (set! span-bar (ly:stencil-translate-axis + span-bar + (- (ly:grob-relative-coordinate grob refp Y)) + Y)))) + span-bar)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; volta bracket functions @@ -892,7 +892,7 @@ no elements." (append volta-bracket-allow-volta-hook-list (list bar-glyph))) (ly:warning (_ ("Volta hook bar line must be a string; ignoring '~a'.") - bar-glyph)))) + bar-glyph)))) (define-session volta-bracket-allow-volta-hook-list '()) @@ -926,8 +926,8 @@ of the volta brackets relative to the bar lines." ;; is the last entry with the same vag-index, so we transform the array to a list, ;; reverse it and search for suitable entries: (filtered-grobs (filter (lambda (e) - (eq? (ly:grob-get-vertical-axis-group-index e) - vag-index)) + (eq? (ly:grob-get-vertical-axis-group-index e) + vag-index)) (reverse (ly:grob-array->list bar-array)))) ;; we need the first one (if any) (right-bar-line (if (pair? filtered-grobs) @@ -946,44 +946,44 @@ of the volta brackets relative to the bar lines." (right-bar-broken (or (null? right-bar-line) (not (zero? (ly:item-break-dir right-bar-line))))) (left-span-stencil-extent (ly:stencil-extent + (span-bar::compound-bar-line + left-bar-line + left-bar-glyph-name + dummy-extent) + X)) + (right-span-stencil-extent (ly:stencil-extent (span-bar::compound-bar-line - left-bar-line - left-bar-glyph-name - dummy-extent) + right-bar-line + right-bar-glyph-name + dummy-extent) X)) - (right-span-stencil-extent (ly:stencil-extent - (span-bar::compound-bar-line - right-bar-line - right-bar-glyph-name - dummy-extent) - X)) (left-shorten 0.0) (right-shorten 0.0)) - ;; since "empty" intervals may look like (1.0 . -1.0), we use the - ;; min/max functions to make sure that the placement is not corrupted - ;; in case of empty bar lines - (set! left-shorten - (if left-bar-broken - (- (max 0 (interval-end left-span-stencil-extent)) - (max 0 (interval-end (ly:stencil-extent - (bar-line::compound-bar-line - left-bar-line - left-bar-glyph-name - dummy-extent) - X))) - volta-half-line-thickness) - (- (max 0 (interval-end left-span-stencil-extent)) - volta-half-line-thickness))) - - (set! right-shorten - (if right-bar-broken - (+ (- (max 0 (interval-end right-span-stencil-extent))) - volta-half-line-thickness) - (- (min 0 (interval-start right-span-stencil-extent)) - volta-half-line-thickness))) - - (cons left-shorten right-shorten))) + ;; since "empty" intervals may look like (1.0 . -1.0), we use the + ;; min/max functions to make sure that the placement is not corrupted + ;; in case of empty bar lines + (set! left-shorten + (if left-bar-broken + (- (max 0 (interval-end left-span-stencil-extent)) + (max 0 (interval-end (ly:stencil-extent + (bar-line::compound-bar-line + left-bar-line + left-bar-glyph-name + dummy-extent) + X))) + volta-half-line-thickness) + (- (max 0 (interval-end left-span-stencil-extent)) + volta-half-line-thickness))) + + (set! right-shorten + (if right-bar-broken + (+ (- (max 0 (interval-end right-span-stencil-extent))) + volta-half-line-thickness) + (- (min 0 (interval-start right-span-stencil-extent)) + volta-half-line-thickness))) + + (cons left-shorten right-shorten))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; predefined bar glyph print procedures diff --git a/scm/bezier-tools.scm b/scm/bezier-tools.scm index 04859d03bb..defefc7bc4 100644 --- a/scm/bezier-tools.scm +++ b/scm/bezier-tools.scm @@ -16,67 +16,67 @@ ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>. (define (make-coord x-value y-value) - "Make a coordinate pair from @var{x-valye} and @var{y-value}." - (cons x-value y-value)) + "Make a coordinate pair from @var{x-valye} and @var{y-value}." + (cons x-value y-value)) (define (coord+ coord1 coord2) - "Add @var{coord1} to @var{coord2}, returning a coordinate." - (cons (+ (car coord1) (car coord2)) - (+ (cdr coord1) (cdr coord2)))) + "Add @var{coord1} to @var{coord2}, returning a coordinate." + (cons (+ (car coord1) (car coord2)) + (+ (cdr coord1) (cdr coord2)))) (define (coord- coord1 coord2) - "Subtract @var{coord2} from @var{coord1}." - (cons (- (car coord1) (car coord2)) - (- (cdr coord1) (cdr coord2)))) + "Subtract @var{coord2} from @var{coord1}." + (cons (- (car coord1) (car coord2)) + (- (cdr coord1) (cdr coord2)))) (define (coord* scalar coord) - "Multiply each component of @var{coord} by @var{scalar}." - (cons (* (car coord) scalar) - (* (cdr coord) scalar))) + "Multiply each component of @var{coord} by @var{scalar}." + (cons (* (car coord) scalar) + (* (cdr coord) scalar))) (define (make-bezier point-0 point-1 point-2 point-3) - "Create a cubic bezier from the four control points." - (list point-0 point-1 point-2 point-3)) + "Create a cubic bezier from the four control points." + (list point-0 point-1 point-2 point-3)) (define (interpolated-control-points control-points split-value) - "Interpolate @var{control-points} at @var{split-value}. Return a + "Interpolate @var{control-points} at @var{split-value}. Return a set of control points that is one degree less than @var{control-points}." (if (null? (cdr control-points)) '() (let ((first (car control-points)) (second (cadr control-points))) - (cons* (coord+ first (coord* split-value (coord- second first))) - (interpolated-control-points - (cdr control-points) - split-value))))) + (cons* (coord+ first (coord* split-value (coord- second first))) + (interpolated-control-points + (cdr control-points) + split-value))))) (define (split-bezier bezier split-value) - "Split a cubic bezier defined by @var{bezier} at the value + "Split a cubic bezier defined by @var{bezier} at the value @var{split-value}. @var{bezier} is a list of pairs; each pair is is the coordinates of a control point. Returns a list of beziers. The first element is the LHS spline; the second element is the RHS spline." - (let* ((quad-points (interpolated-control-points + (let* ((quad-points (interpolated-control-points bezier split-value)) - (lin-points (interpolated-control-points - quad-points + (lin-points (interpolated-control-points + quad-points + split-value)) + (const-point (interpolated-control-points + lin-points split-value)) - (const-point (interpolated-control-points - lin-points - split-value)) - (left-side (list (car bezier) - (car quad-points) - (car lin-points) - (car const-point))) - (right-side (list (car const-point) - (list-ref lin-points 1) - (list-ref quad-points 2) - (list-ref bezier 3)))) - (cons left-side right-side))) + (left-side (list (car bezier) + (car quad-points) + (car lin-points) + (car const-point))) + (right-side (list (car const-point) + (list-ref lin-points 1) + (list-ref quad-points 2) + (list-ref bezier 3)))) + (cons left-side right-side))) (define (multi-split-bezier bezier start-t split-list) - "Split @var{bezier} at all the points listed in @var{split-list}. + "Split @var{bezier} at all the points listed in @var{split-list}. @var{bezier} has a parameter value that goes from @var{start-t} to 1. Returns a list of @var{(1+ (length split-list))} beziers." (let* ((bezier-split (split-bezier bezier @@ -93,13 +93,13 @@ Returns a list of @var{(1+ (length split-list))} beziers." (define (bezier-sandwich-list top-bezier bottom-bezier) - "create the list of control points for a bezier sandwich consisting + "create the list of control points for a bezier sandwich consisting of @var{top-bezier} and @var{bottom-bezier}." - (list (list-ref bottom-bezier 1) - (list-ref bottom-bezier 2) - (list-ref bottom-bezier 3) - (list-ref bottom-bezier 0) - (list-ref top-bezier 2) - (list-ref top-bezier 1) - (list-ref top-bezier 0) - (list-ref top-bezier 3))) + (list (list-ref bottom-bezier 1) + (list-ref bottom-bezier 2) + (list-ref bottom-bezier 3) + (list-ref bottom-bezier 0) + (list-ref top-bezier 2) + (list-ref top-bezier 1) + (list-ref top-bezier 0) + (list-ref top-bezier 3))) diff --git a/scm/c++.scm b/scm/c++.scm index f0c5d3aea9..8f4986a257 100644 --- a/scm/c++.scm +++ b/scm/c++.scm @@ -98,8 +98,8 @@ (if (null? alist) "Unknown type" (if (apply (caar alist) obj) - (cdar alist) - (match-predicate obj (cdr alist))))) + (cdar alist) + (match-predicate obj (cdr alist))))) (define-public (object-type obj) (match-predicate obj type-p-name-alist)) diff --git a/scm/chord-entry.scm b/scm/chord-entry.scm index 28ae97442c..35946731bb 100644 --- a/scm/chord-entry.scm +++ b/scm/chord-entry.scm @@ -26,63 +26,63 @@ Notes: Natural 11 is left from chord if not explicitly specified. Entry point for the parser." (let* ((flat-mods (flatten-list modifications)) - (base-chord (stack-thirds (ly:make-pitch 0 4 0) the-canonical-chord)) - (complete-chord '()) - (bass #f) - (inversion #f) - (lead-mod #f) - (explicit-11 #f) - (start-additions #t)) + (base-chord (stack-thirds (ly:make-pitch 0 4 0) the-canonical-chord)) + (complete-chord '()) + (bass #f) + (inversion #f) + (lead-mod #f) + (explicit-11 #f) + (start-additions #t)) (define (interpret-inversion chord mods) "Read /FOO part. Side effect: INVERSION is set." (if (and (> (length mods) 1) (eq? (car mods) 'chord-slash)) - (begin - (set! inversion (cadr mods)) - (set! mods (cddr mods)))) + (begin + (set! inversion (cadr mods)) + (set! mods (cddr mods)))) (interpret-bass chord mods)) (define (interpret-bass chord mods) "Read /+FOO part. Side effect: BASS is set." (if (and (> (length mods) 1) (eq? (car mods) 'chord-bass)) - (begin - (set! bass (cadr mods)) - (set! mods (cddr mods)))) + (begin + (set! bass (cadr mods)) + (set! mods (cddr mods)))) (if (pair? mods) - (ly:warning (_ "Spurious garbage following chord: ~A") mods)) + (ly:warning (_ "Spurious garbage following chord: ~A") mods)) chord) - (define (interpret-removals chord mods) + (define (interpret-removals chord mods) (define (inner-interpret chord mods) - (if (and (pair? mods) (ly:pitch? (car mods))) - (inner-interpret (remove-step (+ 1 (ly:pitch-steps (car mods))) chord) - (cdr mods)) - (interpret-inversion chord mods))) + (if (and (pair? mods) (ly:pitch? (car mods))) + (inner-interpret (remove-step (+ 1 (ly:pitch-steps (car mods))) chord) + (cdr mods)) + (interpret-inversion chord mods))) (if (and (pair? mods) (eq? (car mods) 'chord-caret)) - (inner-interpret chord (cdr mods)) - (interpret-inversion chord mods))) + (inner-interpret chord (cdr mods)) + (interpret-inversion chord mods))) (define (interpret-additions chord mods) "Interpret additions. TODO: should restrict modifier use?" (cond ((null? mods) chord) - ((ly:pitch? (car mods)) - (if (= (pitch-step (car mods)) 11) - (set! explicit-11 #t)) - (interpret-additions (cons (car mods) (remove-step (pitch-step (car mods)) chord)) - (cdr mods))) - ((procedure? (car mods)) - (interpret-additions ((car mods) chord) - (cdr mods))) - (else (interpret-removals chord mods)))) + ((ly:pitch? (car mods)) + (if (= (pitch-step (car mods)) 11) + (set! explicit-11 #t)) + (interpret-additions (cons (car mods) (remove-step (pitch-step (car mods)) chord)) + (cdr mods))) + ((procedure? (car mods)) + (interpret-additions ((car mods) chord) + (cdr mods))) + (else (interpret-removals chord mods)))) (define (pitch-octavated-strictly-below p root) - "return P, but octavated, so it is below ROOT" + "return P, but octavated, so it is below ROOT" (ly:make-pitch (+ (ly:pitch-octave root) - (if (> (ly:pitch-notename root) - (ly:pitch-notename p)) - 0 -1)) - (ly:pitch-notename p) - (ly:pitch-alteration p))) + (if (> (ly:pitch-notename root) + (ly:pitch-notename p)) + 0 -1)) + (ly:pitch-notename p) + (ly:pitch-alteration p))) (define (process-inversion complete-chord) "Take out inversion from COMPLETE-CHORD, and put it at the bottom. @@ -94,82 +94,82 @@ the bass specified. " (let* ((root (car complete-chord)) - (inv? (lambda (y) - (and (= (ly:pitch-notename y) - (ly:pitch-notename inversion)) - (= (ly:pitch-alteration y) - (ly:pitch-alteration inversion))))) - (rest-of-chord (remove inv? complete-chord)) - (inversion-candidates (filter inv? complete-chord)) - (down-inversion (pitch-octavated-strictly-below inversion root))) - (if (pair? inversion-candidates) - (set! inversion (car inversion-candidates)) - (begin - (set! bass inversion) - (set! inversion #f))) - (if inversion - (cons down-inversion rest-of-chord) - rest-of-chord))) + (inv? (lambda (y) + (and (= (ly:pitch-notename y) + (ly:pitch-notename inversion)) + (= (ly:pitch-alteration y) + (ly:pitch-alteration inversion))))) + (rest-of-chord (remove inv? complete-chord)) + (inversion-candidates (filter inv? complete-chord)) + (down-inversion (pitch-octavated-strictly-below inversion root))) + (if (pair? inversion-candidates) + (set! inversion (car inversion-candidates)) + (begin + (set! bass inversion) + (set! inversion #f))) + (if inversion + (cons down-inversion rest-of-chord) + rest-of-chord))) ;; root is always one octave too low. ;; something weird happens when this is removed, ;; every other chord is octavated. --hwn... hmmm. (set! root (ly:pitch-transpose root (ly:make-pitch 1 0 0))) ;; skip the leading : , we need some of the stuff following it. (if (pair? flat-mods) - (if (eq? (car flat-mods) 'chord-colon) - (set! flat-mods (cdr flat-mods)) - (set! start-additions #f))) + (if (eq? (car flat-mods) 'chord-colon) + (set! flat-mods (cdr flat-mods)) + (set! start-additions #f))) ;; remember modifier (if (and (pair? flat-mods) (procedure? (car flat-mods))) - (begin - (set! lead-mod (car flat-mods)) - (set! flat-mods (cdr flat-mods)))) + (begin + (set! lead-mod (car flat-mods)) + (set! flat-mods (cdr flat-mods)))) ;; extract first number if present, and build pitch list. (if (and (pair? flat-mods) - (ly:pitch? (car flat-mods)) - (not (eq? lead-mod sus-modifier))) - (begin - (if (= (pitch-step (car flat-mods)) 11) - (set! explicit-11 #t)) - (set! base-chord - (stack-thirds (car flat-mods) the-canonical-chord)) - (set! flat-mods (cdr flat-mods)))) + (ly:pitch? (car flat-mods)) + (not (eq? lead-mod sus-modifier))) + (begin + (if (= (pitch-step (car flat-mods)) 11) + (set! explicit-11 #t)) + (set! base-chord + (stack-thirds (car flat-mods) the-canonical-chord)) + (set! flat-mods (cdr flat-mods)))) ;; apply modifier (if (procedure? lead-mod) - (set! base-chord (lead-mod base-chord))) + (set! base-chord (lead-mod base-chord))) (set! complete-chord - (if start-additions - (interpret-additions base-chord flat-mods) - (interpret-removals base-chord flat-mods))) + (if start-additions + (interpret-additions base-chord flat-mods) + (interpret-removals base-chord flat-mods))) (set! complete-chord (sort complete-chord ly:pitch<?)) ;; If natural 11 + natural 3 is present, but not given explicitly, ;; we remove the 11. (if (and (not explicit-11) - (get-step 11 complete-chord) - (get-step 3 complete-chord) - (= 0 (ly:pitch-alteration (get-step 11 complete-chord))) - (= 0 (ly:pitch-alteration (get-step 3 complete-chord)))) - (set! complete-chord (remove-step 11 complete-chord))) + (get-step 11 complete-chord) + (get-step 3 complete-chord) + (= 0 (ly:pitch-alteration (get-step 11 complete-chord))) + (= 0 (ly:pitch-alteration (get-step 3 complete-chord)))) + (set! complete-chord (remove-step 11 complete-chord))) ;; must do before processing inversion/bass, since they are ;; not relative to the root. (set! complete-chord (map (lambda (x) (ly:pitch-transpose x root)) - complete-chord)) + complete-chord)) (if inversion - (set! complete-chord (process-inversion complete-chord))) + (set! complete-chord (process-inversion complete-chord))) (if bass - (set! bass (pitch-octavated-strictly-below bass root))) + (set! bass (pitch-octavated-strictly-below bass root))) (if #f - (begin - (write-me "\n*******\n" flat-mods) - (write-me "root: " root) - (write-me "base chord: " base-chord) - (write-me "complete chord: " complete-chord) - (write-me "inversion: " inversion) - (write-me "bass: " bass))) + (begin + (write-me "\n*******\n" flat-mods) + (write-me "root: " root) + (write-me "base chord: " base-chord) + (write-me "complete chord: " complete-chord) + (write-me "inversion: " inversion) + (write-me "bass: " bass))) (if inversion - (make-chord-elements (cdr complete-chord) bass duration (car complete-chord) - inversion) - (make-chord-elements complete-chord bass duration #f #f)))) + (make-chord-elements (cdr complete-chord) bass duration (car complete-chord) + inversion) + (make-chord-elements complete-chord bass duration #f #f)))) (define (make-chord-elements pitches bass duration inversion original-inv-pitch) @@ -180,23 +180,23 @@ DURATION, and INVERSION." 'duration duration 'pitch pitch)) (let ((nots (map make-note-ev pitches)) - (bass-note (if bass (make-note-ev bass) #f)) - (inv-note (if inversion (make-note-ev inversion) #f))) + (bass-note (if bass (make-note-ev bass) #f)) + (inv-note (if inversion (make-note-ev inversion) #f))) (if bass-note - (begin - (set! (ly:music-property bass-note 'bass) #t) - (set! nots (cons bass-note nots)))) + (begin + (set! (ly:music-property bass-note 'bass) #t) + (set! nots (cons bass-note nots)))) (if inv-note - (begin - (set! (ly:music-property inv-note 'inversion) #t) - (set! (ly:music-property inv-note 'octavation) - (- (ly:pitch-octave inversion) - (ly:pitch-octave original-inv-pitch))) - (set! nots (cons inv-note nots)))) + (begin + (set! (ly:music-property inv-note 'inversion) #t) + (set! (ly:music-property inv-note 'octavation) + (- (ly:pitch-octave inversion) + (ly:pitch-octave original-inv-pitch))) + (set! nots (cons inv-note nots)))) nots)) ;;;;;;;;;;;;;;;; -; chord modifiers change the pitch list. + ; chord modifiers change the pitch list. (define (aug-modifier pitches) (set! pitches (replace-step (ly:make-pitch 0 4 SHARP) pitches)) @@ -229,20 +229,20 @@ DURATION, and INVERSION." ;; canonical 13 chord. (define the-canonical-chord (map (lambda (n) - (define (nca x) - (if (= x 7) FLAT 0)) + (define (nca x) + (if (= x 7) FLAT 0)) - (if (>= n 8) - (ly:make-pitch 1 (- n 8) (nca n)) - (ly:make-pitch 0 (- n 1) (nca n)))) + (if (>= n 8) + (ly:make-pitch 1 (- n 8) (nca n)) + (ly:make-pitch 0 (- n 1) (nca n)))) '(1 3 5 7 9 11 13))) (define (stack-thirds upper-step base) "Stack thirds listed in BASE until we reach UPPER-STEP. Add UPPER-STEP separately." (cond ((null? base) '()) - ((> (ly:pitch-steps upper-step) (ly:pitch-steps (car base))) - (cons (car base) (stack-thirds upper-step (cdr base)))) - ((<= (ly:pitch-steps upper-step) (ly:pitch-steps (car base))) - (list upper-step)) - (else '()))) + ((> (ly:pitch-steps upper-step) (ly:pitch-steps (car base))) + (cons (car base) (stack-thirds upper-step (cdr base)))) + ((<= (ly:pitch-steps upper-step) (ly:pitch-steps (car base))) + (list upper-step)) + (else '()))) diff --git a/scm/chord-generic-names.scm b/scm/chord-generic-names.scm index abc39e3518..c366a70b54 100644 --- a/scm/chord-generic-names.scm +++ b/scm/chord-generic-names.scm @@ -23,7 +23,7 @@ (define (default-note-namer pitch) - (note-name->markup pitch #f)) + (note-name->markup pitch #f)) (define (markup-or-empty-markup markup) "Return MARKUP if markup, else empty-markup" @@ -34,7 +34,7 @@ (if bool (make-line-markup (list (make-hspace-markup amount) - markup)) + markup)) markup)) (define-public (banter-chord-names pitches bass inversion context) @@ -46,7 +46,7 @@ 'jazz pitches bass inversion context '())) (define-public (ugh-compat-double-plus-new-chord->markup - style pitches bass inversion context options) + style pitches bass inversion context options) "Entry point for @code{New_chord_name_engraver}. FIXME: func, options/context have changed @@ -57,35 +57,35 @@ See @file{double-plus-new-chord-name.scm} for the signature of @var{style}. (define (step-nr pitch) (let* ((pitch-nr (+ (* 7 (ly:pitch-octave pitch)) - (ly:pitch-notename pitch))) - (root-nr (+ (* 7 (ly:pitch-octave (car pitches))) - (ly:pitch-notename (car pitches))))) + (ly:pitch-notename pitch))) + (root-nr (+ (* 7 (ly:pitch-octave (car pitches))) + (ly:pitch-notename (car pitches))))) (+ 1 (- pitch-nr root-nr)))) (define (next-third pitch) (ly:pitch-transpose pitch - (ly:make-pitch 0 2 (if (or (= (step-nr pitch) 3) - (= (step-nr pitch) 5)) - FLAT 0)))) + (ly:make-pitch 0 2 (if (or (= (step-nr pitch) 3) + (= (step-nr pitch) 5)) + FLAT 0)))) (define (step-alteration pitch) (let* ((diff (ly:pitch-diff (ly:make-pitch 0 0 0) (car pitches))) - (normalized-pitch (ly:pitch-transpose pitch diff)) - (alteration (ly:pitch-alteration normalized-pitch))) + (normalized-pitch (ly:pitch-transpose pitch diff)) + (alteration (ly:pitch-alteration normalized-pitch))) (if (= (step-nr pitch) 7) (+ alteration SEMI-TONE) alteration))) (define (pitch-unalter pitch) (let ((alteration (step-alteration pitch))) (if (= alteration 0) - pitch - (ly:make-pitch (ly:pitch-octave pitch) (ly:pitch-notename pitch) - (- (ly:pitch-alteration pitch) alteration))))) + pitch + (ly:make-pitch (ly:pitch-octave pitch) (ly:pitch-notename pitch) + (- (ly:pitch-alteration pitch) alteration))))) (define (step-even-or-altered? pitch) (let ((nr (step-nr pitch))) (if (!= (modulo nr 2) 0) - (!= (step-alteration pitch) 0) - #t))) + (!= (step-alteration pitch) 0) + #t))) (define (step->markup-plusminus pitch) (make-line-markup @@ -93,111 +93,111 @@ See @file{double-plus-new-chord-name.scm} for the signature of @var{style}. (make-simple-markup (number->string (step-nr pitch))) (make-simple-markup (case (step-alteration pitch) - ((DOUBLE-FLAT) "--") - ((FLAT) "-") - ((NATURAL) "") - ((SHARP) "+") - ((DOUBLE-SHARP) "++")))))) + ((DOUBLE-FLAT) "--") + ((FLAT) "-") + ((NATURAL) "") + ((SHARP) "+") + ((DOUBLE-SHARP) "++")))))) (define (step->markup-accidental pitch) (make-line-markup (list (accidental->markup (step-alteration pitch)) - (make-simple-markup (number->string (step-nr pitch)))))) + (make-simple-markup (number->string (step-nr pitch)))))) (define (step->markup-ignatzek pitch) (make-line-markup (if (and (= (step-nr pitch) 7) - (= (step-alteration pitch) 1)) - (list (ly:context-property context 'majorSevenSymbol)) - (list (accidental->markup (step-alteration pitch)) - (make-simple-markup (number->string (step-nr pitch))))))) + (= (step-alteration pitch) 1)) + (list (ly:context-property context 'majorSevenSymbol)) + (list (accidental->markup (step-alteration pitch)) + (make-simple-markup (number->string (step-nr pitch))))))) ;; tja, kennok (define (make-sub->markup step->markup) (lambda (pitch) (make-line-markup (list (make-simple-markup "no") - (step->markup pitch))))) + (step->markup pitch))))) (define (step-based-sub->markup step->markup pitch) (make-line-markup (list (make-simple-markup "no") (step->markup pitch)))) (define (get-full-list pitch) (if (<= (step-nr pitch) (step-nr (last pitches))) - (cons pitch (get-full-list (next-third pitch))) - '())) + (cons pitch (get-full-list (next-third pitch))) + '())) (define (get-consecutive nr pitches) (if (pair? pitches) - (let* ((pitch-nr (step-nr (car pitches))) - (next-nr (if (!= (modulo pitch-nr 2) 0) (+ pitch-nr 2) nr))) - (if (<= pitch-nr nr) - (cons (car pitches) (get-consecutive next-nr (cdr pitches))) - '())) - '())) + (let* ((pitch-nr (step-nr (car pitches))) + (next-nr (if (!= (modulo pitch-nr 2) 0) (+ pitch-nr 2) nr))) + (if (<= pitch-nr nr) + (cons (car pitches) (get-consecutive next-nr (cdr pitches))) + '())) + '())) (define (full-match exceptions) (if (pair? exceptions) - (let* ((e (car exceptions)) - (e-pitches (car e))) - (if (equal? e-pitches pitches) - e - (full-match (cdr exceptions)))) - #f)) + (let* ((e (car exceptions)) + (e-pitches (car e))) + (if (equal? e-pitches pitches) + e + (full-match (cdr exceptions)))) + #f)) (define (partial-match exceptions) (if (pair? exceptions) - (let* ((e (car exceptions)) - (e-pitches (car e))) - (if (equal? e-pitches (take pitches (length e-pitches))) - e - (partial-match (cdr exceptions)))) - #f)) + (let* ((e (car exceptions)) + (e-pitches (car e))) + (if (equal? e-pitches (take pitches (length e-pitches))) + e + (partial-match (cdr exceptions)))) + #f)) (if #f (begin - (write-me "pitches: " pitches))) + (write-me "pitches: " pitches))) (let* ((full-exceptions - (ly:context-property context 'chordNameExceptionsFull)) - (full-exception (full-match full-exceptions)) - (full-markup (if full-exception (cadr full-exception) '())) - (partial-exceptions - (ly:context-property context 'chordNameExceptionsPartial)) - (partial-exception (partial-match partial-exceptions)) - (partial-pitches (if partial-exception (car partial-exception) '())) - (partial-markup-prefix - (if partial-exception (markup-or-empty-markup - (cadr partial-exception)) empty-markup)) - (partial-markup-suffix - (if (and partial-exception (pair? (cddr partial-exception))) - (markup-or-empty-markup (caddr partial-exception)) empty-markup)) - (root (car pitches)) - (full (get-full-list root)) - ;; kludge alert: replace partial matched lower part of all with - ;; 'normal' pitches from full - ;; (all pitches) - (all (append (take full (length partial-pitches)) - (drop pitches (length partial-pitches)))) - - (highest (last all)) - (missing (list-minus full (map pitch-unalter all))) - (consecutive (get-consecutive 1 all)) - (rest (list-minus all consecutive)) - (altered (filter step-even-or-altered? all)) - (cons-alt (filter step-even-or-altered? consecutive)) - (base (list-minus consecutive altered))) + (ly:context-property context 'chordNameExceptionsFull)) + (full-exception (full-match full-exceptions)) + (full-markup (if full-exception (cadr full-exception) '())) + (partial-exceptions + (ly:context-property context 'chordNameExceptionsPartial)) + (partial-exception (partial-match partial-exceptions)) + (partial-pitches (if partial-exception (car partial-exception) '())) + (partial-markup-prefix + (if partial-exception (markup-or-empty-markup + (cadr partial-exception)) empty-markup)) + (partial-markup-suffix + (if (and partial-exception (pair? (cddr partial-exception))) + (markup-or-empty-markup (caddr partial-exception)) empty-markup)) + (root (car pitches)) + (full (get-full-list root)) + ;; kludge alert: replace partial matched lower part of all with + ;; 'normal' pitches from full + ;; (all pitches) + (all (append (take full (length partial-pitches)) + (drop pitches (length partial-pitches)))) + + (highest (last all)) + (missing (list-minus full (map pitch-unalter all))) + (consecutive (get-consecutive 1 all)) + (rest (list-minus all consecutive)) + (altered (filter step-even-or-altered? all)) + (cons-alt (filter step-even-or-altered? consecutive)) + (base (list-minus consecutive altered))) (if #f (begin - (write-me "full:" full) - ;; (write-me "partial-pitches:" partial-pitches) - (write-me "full-markup:" full-markup) - (write-me "partial-markup-perfix:" partial-markup-prefix) - (write-me "partial-markup-suffix:" partial-markup-suffix) - (write-me "all:" all) - (write-me "altered:" altered) - (write-me "missing:" missing) - (write-me "consecutive:" consecutive) - (write-me "rest:" rest) - (write-me "base:" base))) + (write-me "full:" full) + ;; (write-me "partial-pitches:" partial-pitches) + (write-me "full-markup:" full-markup) + (write-me "partial-markup-perfix:" partial-markup-prefix) + (write-me "partial-markup-suffix:" partial-markup-suffix) + (write-me "all:" all) + (write-me "altered:" altered) + (write-me "missing:" missing) + (write-me "consecutive:" consecutive) + (write-me "rest:" rest) + (write-me "base:" base))) (case style ((banter) @@ -206,36 +206,36 @@ See @file{double-plus-new-chord-name.scm} for the signature of @var{style}. ;; + subs:missing (let* ((root->markup (assoc-get - 'root->markup options default-note-namer)) - (step->markup (assoc-get - 'step->markup options step->markup-plusminus)) - (sub->markup (assoc-get - 'sub->markup options - (lambda (x) - (step-based-sub->markup step->markup x)))) - (sep (assoc-get - 'separator options (make-simple-markup "/")))) - - (if - (pair? full-markup) - (make-line-markup (list (root->markup root) full-markup)) - - (make-line-markup - (list - (root->markup root) - partial-markup-prefix - (make-normal-size-super-markup - (markup-join - (apply append - (map step->markup - (append altered - (if (and (> (step-nr highest) 5) - (not - (step-even-or-altered? highest))) - (list highest) '()))) - (list partial-markup-suffix) - (list (map sub->markup missing))) - sep))))))) + 'root->markup options default-note-namer)) + (step->markup (assoc-get + 'step->markup options step->markup-plusminus)) + (sub->markup (assoc-get + 'sub->markup options + (lambda (x) + (step-based-sub->markup step->markup x)))) + (sep (assoc-get + 'separator options (make-simple-markup "/")))) + + (if + (pair? full-markup) + (make-line-markup (list (root->markup root) full-markup)) + + (make-line-markup + (list + (root->markup root) + partial-markup-prefix + (make-normal-size-super-markup + (markup-join + (apply append + (map step->markup + (append altered + (if (and (> (step-nr highest) 5) + (not + (step-even-or-altered? highest))) + (list highest) '()))) + (list partial-markup-suffix) + (list (map sub->markup missing))) + sep))))))) ((jazz) @@ -244,49 +244,49 @@ See @file{double-plus-new-chord-name.scm} for the signature of @var{style}. ;; + 'add' ;; + steps:rest (let* ((root->markup (assoc-get - 'root->markup options default-note-namer)) - (step->markup - (assoc-get - ;; FIXME: ignatzek - ;;'step->markup options step->markup-accidental)) - 'step->markup options step->markup-ignatzek)) - (sep (assoc-get - 'separator options (make-simple-markup " "))) - (add-prefix (assoc-get 'add-prefix options - (make-simple-markup " add")))) - - (if - (pair? full-markup) - (make-line-markup (list (root->markup root) full-markup)) - - (make-line-markup - (list - (root->markup root) - partial-markup-prefix - (make-normal-size-super-markup - (make-line-markup - (list - - ;; kludge alert: omit <= 5 - ;;(markup-join (map step->markup - ;; (cons (last base) cons-alt)) sep) - - ;; This fixes: - ;; c C5 -> C - ;; c:2 C5 2 -> C2 - ;; c:3- Cm5 -> Cm - ;; c:6.9 C5 6add9 -> C6 add 9 (add?) - ;; ch = \chords { c c:2 c:3- c:6.9^7 } - (markup-join (map step->markup - (let ((tb (last base))) - (if (> (step-nr tb) 5) - (cons tb cons-alt) - cons-alt))) sep) - - (if (pair? rest) - add-prefix - empty-markup) - (markup-join (map step->markup rest) sep) - partial-markup-suffix)))))))) - - (else empty-markup)))) + 'root->markup options default-note-namer)) + (step->markup + (assoc-get + ;; FIXME: ignatzek + ;;'step->markup options step->markup-accidental)) + 'step->markup options step->markup-ignatzek)) + (sep (assoc-get + 'separator options (make-simple-markup " "))) + (add-prefix (assoc-get 'add-prefix options + (make-simple-markup " add")))) + + (if + (pair? full-markup) + (make-line-markup (list (root->markup root) full-markup)) + + (make-line-markup + (list + (root->markup root) + partial-markup-prefix + (make-normal-size-super-markup + (make-line-markup + (list + + ;; kludge alert: omit <= 5 + ;;(markup-join (map step->markup + ;; (cons (last base) cons-alt)) sep) + + ;; This fixes: + ;; c C5 -> C + ;; c:2 C5 2 -> C2 + ;; c:3- Cm5 -> Cm + ;; c:6.9 C5 6add9 -> C6 add 9 (add?) + ;; ch = \chords { c c:2 c:3- c:6.9^7 } + (markup-join (map step->markup + (let ((tb (last base))) + (if (> (step-nr tb) 5) + (cons tb cons-alt) + cons-alt))) sep) + + (if (pair? rest) + add-prefix + empty-markup) + (markup-join (map step->markup rest) sep) + partial-markup-suffix)))))))) + + (else empty-markup)))) diff --git a/scm/chord-name.scm b/scm/chord-name.scm index 606d806660..c75d91ba97 100644 --- a/scm/chord-name.scm +++ b/scm/chord-name.scm @@ -35,8 +35,8 @@ (make-smaller-markup (make-raise-markup (if (= alteration FLAT) - 0.3 - 0.6) + 0.3 + 0.6) (make-musicglyph-markup (assoc-get alteration standard-alteration-glyph-name-alist ""))))) @@ -55,9 +55,9 @@ (make-line-markup (list (make-hspace-markup (if (= alteration FLAT) 0.57285385 0.5)) - (make-raise-markup 0.7 (alteration->text-accidental-markup alteration)) - (make-hspace-markup (if (= alteration SHARP) 0.2 0.1)) - )))) + (make-raise-markup 0.7 (alteration->text-accidental-markup alteration)) + (make-hspace-markup (if (= alteration SHARP) 0.2 0.1)) + )))) (define-public (note-name->markup pitch lowercase?) "Return pitch markup for @var{pitch}." @@ -73,38 +73,38 @@ (inexact->exact (round (* (ly:pitch-alteration pitch) 2)))) (define-safe-public ((chord-name->german-markup B-instead-of-Bb) - pitch lowercase?) + pitch lowercase?) "Return pitch markup for PITCH, using german note names. If B-instead-of-Bb is set to #t real german names are returned. Otherwise semi-german names (with Bb and below keeping the british names) " (let* ((name (ly:pitch-notename pitch)) (alt-semitones (pitch-alteration-semitones pitch)) - (n-a (if (member (cons name alt-semitones) `((6 . -1) (6 . -2))) - (cons 7 (+ (if B-instead-of-Bb 1 0) alt-semitones)) - (cons name alt-semitones)))) + (n-a (if (member (cons name alt-semitones) `((6 . -1) (6 . -2))) + (cons 7 (+ (if B-instead-of-Bb 1 0) alt-semitones)) + (cons name alt-semitones)))) (make-line-markup (list (make-simple-markup (conditional-string-downcase - (vector-ref #("C" "D" "E" "F" "G" "A" "H" "B") (car n-a)) - lowercase?)) + (vector-ref #("C" "D" "E" "F" "G" "A" "H" "B") (car n-a)) + lowercase?)) (make-normal-size-super-markup (accidental->markup (/ (cdr n-a) 2))))))) (define-safe-public (note-name->german-markup pitch lowercase?) (let* ((name (ly:pitch-notename pitch)) - (alt-semitones (pitch-alteration-semitones pitch)) - (n-a (if (member (cons name alt-semitones) `((6 . -1) (6 . -2))) - (cons 7 (+ 1 alt-semitones)) - (cons name alt-semitones)))) + (alt-semitones (pitch-alteration-semitones pitch)) + (n-a (if (member (cons name alt-semitones) `((6 . -1) (6 . -2))) + (cons 7 (+ 1 alt-semitones)) + (cons name alt-semitones)))) (make-line-markup (list (string-append (list-ref '("c" "d" "e" "f" "g" "a" "h" "b") (car n-a)) (if (or (equal? (car n-a) 2) (equal? (car n-a) 5)) - (list-ref '( "ses" "s" "" "is" "isis") (+ 2 (cdr n-a))) - (list-ref '("eses" "es" "" "is" "isis") (+ 2 (cdr n-a))))))))) + (list-ref '( "ses" "s" "" "is" "isis") (+ 2 (cdr n-a))) + (list-ref '("eses" "es" "" "is" "isis") (+ 2 (cdr n-a))))))))) (define-public ((chord-name->italian-markup re-with-eacute) pitch lowercase?) "Return pitch markup for @var{pitch}, using Italian/@/French note names. @@ -117,12 +117,12 @@ pitch@tie{}D instead of `re'." (list (make-simple-markup (conditional-string-downcase - (vector-ref - (if re-with-eacute - #("Do" "Ré" "Mi" "Fa" "Sol" "La" "Si") - #("Do" "Re" "Mi" "Fa" "Sol" "La" "Si")) - name) - lowercase?)) + (vector-ref + (if re-with-eacute + #("Do" "Ré" "Mi" "Fa" "Sol" "La" "Si") + #("Do" "Re" "Mi" "Fa" "Sol" "La" "Si")) + name) + lowercase?)) (accidental->markup-italian alt) )))) @@ -136,29 +136,29 @@ FOOBAR-MARKUP) if OMIT-ROOT is given and non-false. (define (chord-to-exception-entry m) (let* ((elts (ly:music-property m 'elements)) - (omit-root (and (pair? rest) (car rest))) - (pitches (map (lambda (x) (ly:music-property x 'pitch)) - (filter - (lambda (y) (memq 'note-event - (ly:music-property y 'types))) - elts))) - (sorted (sort pitches ly:pitch<?)) - (root (car sorted)) - - ;; ugh? - ;;(diff (ly:pitch-diff root (ly:make-pitch -1 0 0))) - ;; FIXME. This results in #<Pitch c> ..., - ;; but that is what we need because default octave for - ;; \chords has changed to c' too? - (diff (ly:pitch-diff root (ly:make-pitch 0 0 0))) - (normalized (map (lambda (x) (ly:pitch-diff x diff)) sorted)) - (texts (map (lambda (x) (ly:music-property x 'text)) - (filter - (lambda (y) (memq 'text-script-event - (ly:music-property y 'types))) - elts))) - - (text (if (null? texts) #f (if omit-root (car texts) texts)))) + (omit-root (and (pair? rest) (car rest))) + (pitches (map (lambda (x) (ly:music-property x 'pitch)) + (filter + (lambda (y) (memq 'note-event + (ly:music-property y 'types))) + elts))) + (sorted (sort pitches ly:pitch<?)) + (root (car sorted)) + + ;; ugh? + ;;(diff (ly:pitch-diff root (ly:make-pitch -1 0 0))) + ;; FIXME. This results in #<Pitch c> ..., + ;; but that is what we need because default octave for + ;; \chords has changed to c' too? + (diff (ly:pitch-diff root (ly:make-pitch 0 0 0))) + (normalized (map (lambda (x) (ly:pitch-diff x diff)) sorted)) + (texts (map (lambda (x) (ly:music-property x 'text)) + (filter + (lambda (y) (memq 'text-script-event + (ly:music-property y 'types))) + elts))) + + (text (if (null? texts) #f (if omit-root (car texts) texts)))) (cons (if omit-root (cdr normalized) normalized) text))) (define (is-event-chord? m) @@ -167,6 +167,6 @@ FOOBAR-MARKUP) if OMIT-ROOT is given and non-false. (not (equal? ZERO-MOMENT (ly:music-length m))))) (let* ((elts (filter is-event-chord? (ly:music-property seq 'elements))) - (alist (map chord-to-exception-entry elts))) + (alist (map chord-to-exception-entry elts))) (filter (lambda (x) (cdr x)) alist))) diff --git a/scm/clip-region.scm b/scm/clip-region.scm index 890cb657e3..5cfc4449e7 100644 --- a/scm/clip-region.scm +++ b/scm/clip-region.scm @@ -25,18 +25,18 @@ ;; scm/output-lib.scm ;; ;; -;; (define-public (make-rhythmic-location bar-num num den) -;; (define-public (rhythmic-location? a) -;; (define-public (make-graceless-rhythmic-location loc) -;; (define-public rhythmic-location-measure-position cdr) -;; (define-public rhythmic-location-bar-number car) -;; (define-public (rhythmic-location<? a b) -;; (define-public (rhythmic-location<=? a b) -;; (define-public (rhythmic-location>=? a b) -;; (define-public (rhythmic-location>? a b) -;; (define-public (rhythmic-location=? a b) -;; (define-public (rhythmic-location->file-string a) -;; (define-public (rhythmic-location->string a) +;; (define-public (make-rhythmic-location bar-num num den) +;; (define-public (rhythmic-location? a) +;; (define-public (make-graceless-rhythmic-location loc) +;; (define-public rhythmic-location-measure-position cdr) +;; (define-public rhythmic-location-bar-number car) +;; (define-public (rhythmic-location<? a b) +;; (define-public (rhythmic-location<=? a b) +;; (define-public (rhythmic-location>=? a b) +;; (define-public (rhythmic-location>? a b) +;; (define-public (rhythmic-location=? a b) +;; (define-public (rhythmic-location->file-string a) +;; (define-public (rhythmic-location->string a) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -59,52 +59,52 @@ (region-end (cdr clip-region)) (found-grace-end #f) (candidate-columns - (filter - (lambda (j) - (let* - ((column (ly:grob-array-ref columns j)) - (loc (ly:grob-property column 'rhythmic-location)) - (grace-less (make-graceless-rhythmic-location loc)) - ) + (filter + (lambda (j) + (let* + ((column (ly:grob-array-ref columns j)) + (loc (ly:grob-property column 'rhythmic-location)) + (grace-less (make-graceless-rhythmic-location loc)) + ) - (and (rhythmic-location? loc) - (rhythmic-location<=? region-start loc) - (or (rhythmic-location<? grace-less region-end) - (and (rhythmic-location=? grace-less region-end) - (eq? #t (ly:grob-property column 'non-musical)) + (and (rhythmic-location? loc) + (rhythmic-location<=? region-start loc) + (or (rhythmic-location<? grace-less region-end) + (and (rhythmic-location=? grace-less region-end) + (eq? #t (ly:grob-property column 'non-musical)) - ))) + ))) - )) + )) - (iota (ly:grob-array-length columns)))) + (iota (ly:grob-array-length columns)))) (column-range - (if (>= 1 (length candidate-columns)) - #f - (cons (car candidate-columns) - (car (last-pair candidate-columns))))) + (if (>= 1 (length candidate-columns)) + #f + (cons (car candidate-columns) + (car (last-pair candidate-columns))))) (clipped-x-interval - (if column-range - (cons - - (interval-start - (ly:grob-robust-relative-extent - (if (= 0 (car column-range)) - system-grob - (ly:grob-array-ref columns (car column-range))) - system-grob X)) - - (interval-end - (ly:grob-robust-relative-extent - (if (= (1- (ly:grob-array-length columns)) (cdr column-range)) - system-grob - (ly:grob-array-ref columns (cdr column-range))) - system-grob X))) - - - #f - ))) + (if column-range + (cons + + (interval-start + (ly:grob-robust-relative-extent + (if (= 0 (car column-range)) + system-grob + (ly:grob-array-ref columns (car column-range))) + system-grob X)) + + (interval-end + (ly:grob-robust-relative-extent + (if (= (1- (ly:grob-array-length columns)) (cdr column-range)) + system-grob + (ly:grob-array-ref columns (cdr column-range))) + system-grob X))) + + + #f + ))) clipped-x-interval)) diff --git a/scm/coverage.scm b/scm/coverage.scm index 3c210555ae..75016517a2 100644 --- a/scm/coverage.scm +++ b/scm/coverage.scm @@ -3,28 +3,28 @@ (define-module (scm coverage)) (use-modules (lily) - (ice-9 rdelim) - (ice-9 regex) - (ice-9 format) ;; needed for ~8@ - ) + (ice-9 rdelim) + (ice-9 regex) + (ice-9 format) ;; needed for ~8@ + ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-public (coverage:show-all filter?) (let* ((keys - (filter filter? - (sort (map car (hash-table->alist coverage-table)) string<? )))) - - (newline) - (for-each - (lambda (k) + (filter filter? + (sort (map car (hash-table->alist coverage-table)) string<? )))) - (format #t "Coverage for file: ~a\n" k) - (display-coverage - k (hash-ref coverage-table k) - (format #f "~a.cov" (basename k)))) - keys))) + (newline) + (for-each + (lambda (k) + + (format #t "Coverage for file: ~a\n" k) + (display-coverage + k (hash-ref coverage-table k) + (format #f "~a.cov" (basename k)))) + keys))) (define-public (coverage:enable) @@ -32,7 +32,7 @@ (trap-enable 'memoize-symbol) (trap-enable 'traps)) - + (define-public (coverage:disable) (trap-set! memoize-symbol-handler #f) (trap-disable 'memoize-symbol)) @@ -49,27 +49,27 @@ ((lines (read-lines (open-file file "r"))) (format-str "~8@a: ~5@a:~a\n") (out (if out-file (open-output-file out-file) - (current-output-port)))) + (current-output-port)))) (format out format-str "-" 0 (format #f "Source:~a" file)) (do - ((i 0 (1+ i)) - (l lines (cdr l))) - ((or (null? l) )) + ((i 0 (1+ i)) + (l lines (cdr l))) + ((or (null? l) )) (format out format-str - (cond - ((and (< i (vector-length vec)) (vector-ref vec i)) "1") - ((and (string-contains file ".ly") (string-match "^[ \t]*%.*$" (car l))) - "-") - ((string-match "^[ \t]*[()'`,]*$" (car l)) - "-") - ((string-match "^[ \t]*;.*$" (car l)) - - "-") - (else "0")) - (1+ i) - (car l))))) + (cond + ((and (< i (vector-length vec)) (vector-ref vec i)) "1") + ((and (string-contains file ".ly") (string-match "^[ \t]*%.*$" (car l))) + "-") + ((string-match "^[ \t]*[()'`,]*$" (car l)) + "-") + ((string-match "^[ \t]*;.*$" (car l)) + + "-") + (else "0")) + (1+ i) + (car l))))) (define (record-coverage key cont exp env) (let* @@ -78,20 +78,20 @@ (vec (and name (hash-ref coverage-table name #f))) (veclen (and vec (vector-length vec))) (veccopy (lambda (src dst) - (vector-move-left! src 0 (vector-length src) - dst 0) - dst))) + (vector-move-left! src 0 (vector-length src) + dst 0) + dst))) (if (and line name) - (begin - (if (or (not vec) (>= line (vector-length vec))) - (set! vec - (hash-set! coverage-table name - (if vec - (veccopy vec (make-vector (1+ line) #f)) - (make-vector (1+ line) #f))))) - - (vector-set! vec line #t)) - ))) + (begin + (if (or (not vec) (>= line (vector-length vec))) + (set! vec + (hash-set! coverage-table name + (if vec + (veccopy vec (make-vector (1+ line) #f)) + (make-vector (1+ line) #f))))) + + (vector-set! vec line #t)) + ))) diff --git a/scm/define-context-properties.scm b/scm/define-context-properties.scm index 4839493dd7..baf8163518 100644 --- a/scm/define-context-properties.scm +++ b/scm/define-context-properties.scm @@ -21,9 +21,9 @@ (define (translator-property-description symbol type? description) (if (not (and - (symbol? symbol) - (procedure? type?) - (string? description))) + (symbol? symbol) + (procedure? type?) + (string? description))) (throw 'init-format-error)) @@ -516,9 +516,9 @@ voices is preserved. @example @{ r1 r1*3 R1*3 - \\set Score.skipBars= ##t - r1*3 R1*3 -@} + \\set Score.skipBars= ##t + r1*3 R1*3 + @} @end example") (skipTypesetting ,boolean? "If true, no typesetting is done, speeding up the interpretation phase. Useful for debugging large @@ -714,7 +714,7 @@ and subscripts. See @file{scm/@/script.scm} for more information.") (define-public all-translation-properties (append all-user-translation-properties - all-internal-translation-properties)) + all-internal-translation-properties)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/scm/define-event-classes.scm b/scm/define-event-classes.scm index 9b00af992b..fb790a591f 100644 --- a/scm/define-event-classes.scm +++ b/scm/define-event-classes.scm @@ -22,10 +22,10 @@ (define event-classes '((() . (StreamEvent)) (StreamEvent . - (RemoveContext - ChangeParent Override Revert UnsetProperty SetProperty - music-event OldMusicEvent CreateContext Prepare - OneTimeStep Finish)) + (RemoveContext + ChangeParent Override Revert UnsetProperty SetProperty + music-event OldMusicEvent CreateContext Prepare + OneTimeStep Finish)) (music-event . (annotate-output-event footnote-event arpeggio-event breathing-event extender-event span-event rhythmic-event dynamic-event @@ -57,9 +57,9 @@ (pedal-event . (sostenuto-event sustain-event una-corda-event)) (rhythmic-event . (lyric-event melodic-event multi-measure-rest-event - double-percent-event percent-event - repeat-slash-event rest-event - skip-event bass-figure-event)) + double-percent-event percent-event + repeat-slash-event rest-event + skip-event bass-figure-event)) (melodic-event . (cluster-note-event note-event)) (() . (Announcement)) (Announcement . (AnnounceNewContext)) @@ -68,15 +68,15 @@ (define-public (event-class-cons class parent classlist) (let ((lineage (assq parent classlist))) (if (not lineage) - (begin - (if (not (null? parent)) - (ly:warning (_ "unknown parent class `~a'") parent)) - (set! lineage '()))) + (begin + (if (not (null? parent)) + (ly:warning (_ "unknown parent class `~a'") parent)) + (set! lineage '()))) (if (symbol? class) - (acons class lineage classlist) - (fold (lambda (elt alist) - (acons elt lineage alist)) - classlist class)))) + (acons class lineage classlist) + (fold (lambda (elt alist) + (acons elt lineage alist)) + classlist class)))) ;; Each class will be defined as ;; (class parent grandparent .. ) @@ -88,8 +88,8 @@ (define-public all-event-classes (fold (lambda (elt classlist) - (event-class-cons (cdr elt) (car elt) classlist)) - '() event-classes)) + (event-class-cons (cdr elt) (car elt) classlist)) + '() event-classes)) ;; does this exist in guile already? (define (map-tree f t) @@ -104,24 +104,24 @@ (define (expand-event-tree root) (let ((children (assq root event-classes))) (if children - (cons root (map expand-event-tree (cdr children))) - root))) + (cons root (map expand-event-tree (cdr children))) + root))) ;; produce neater representation of music event tree. ;; TODO: switch to this representation for the event-classes list? (define music-event-tree (expand-event-tree 'music-event)) (define (sort-tree t) (define (stringify el) - (if (symbol? el) - (symbol->string el) - (symbol->string (first el)))) + (if (symbol? el) + (symbol->string el) + (symbol->string (first el)))) (if (list? t) (sort (map (lambda (el) - (if (list? el) - (cons (car el) (sort-tree (cdr el))) - el)) - t) - (lambda (a b) (string<? (stringify a) (stringify b)))) + (if (list? el) + (cons (car el) (sort-tree (cdr el))) + el)) + t) + (lambda (a b) (string<? (stringify a) (stringify b)))) t)) ;;(use-modules (ice-9 pretty-print)) @@ -135,29 +135,29 @@ ;; Special case for lists reduces stack consumption. ((list? e) (map simplify e)) ((pair? e) (cons (simplify (car e)) - (simplify (cdr e)))) + (simplify (cdr e)))) ((ly:stream-event? e) (list 'unquote (list 'make-stream-event (simplify (Stream_event::dump e))))) ((ly:music? e) (list 'unquote (music->make-music e))) ((ly:moment? e) (list 'unquote `(ly:make-moment - ,(ly:moment-main-numerator e) - ,(ly:moment-main-denominator e) - . ,(if (zero? (ly:moment-grace-numerator e)) - '() - (list (ly:moment-grace-numerator e) - (ly:moment-grace-denominator e)))))) + ,(ly:moment-main-numerator e) + ,(ly:moment-main-denominator e) + . ,(if (zero? (ly:moment-grace-numerator e)) + '() + (list (ly:moment-grace-numerator e) + (ly:moment-grace-denominator e)))))) ((ly:duration? e) (list 'unquote `(ly:make-duration - ,(ly:duration-log e) - ,(ly:duration-dot-count e) - ,(ly:duration-scale)))) + ,(ly:duration-log e) + ,(ly:duration-dot-count e) + ,(ly:duration-scale)))) ((ly:pitch? e) (list 'unquote `(ly:make-pitch - ,(ly:pitch-octave e) - ,(ly:pitch-notename e) - ,(ly:pitch-alteration e)))) + ,(ly:pitch-octave e) + ,(ly:pitch-notename e) + ,(ly:pitch-alteration e)))) ((ly:input-location? e) (list 'unquote '(ly:dummy-input-location))) (#t e))) diff --git a/scm/define-grob-interfaces.scm b/scm/define-grob-interfaces.scm index ad4f96e4bb..54d360903a 100644 --- a/scm/define-grob-interfaces.scm +++ b/scm/define-grob-interfaces.scm @@ -78,10 +78,10 @@ found in @file{scm/bar-line.scm}. (ly:add-interface 'clef-modifier-interface - "The number describing transposition of the clef, placed below + "The number describing transposition of the clef, placed below or above clef sign. Usually this is 8 (octave transposition) or 15 (two octaves), but LilyPond allows any integer here." - '()) + '()) (ly:add-interface 'dynamic-interface @@ -137,9 +137,9 @@ or 15 (two octaves), but LilyPond allows any integer here." thickness)) (ly:add-interface - 'glissando-interface - "A glissando." - '(glissando-index)) + 'glissando-interface + "A glissando." + '(glissando-index)) (ly:add-interface 'grace-spacing-interface diff --git a/scm/define-grob-properties.scm b/scm/define-grob-properties.scm index 6434c15c46..809083cf52 100644 --- a/scm/define-grob-properties.scm +++ b/scm/define-grob-properties.scm @@ -31,9 +31,9 @@ (apply define-grob-property x)) `( -;; -;; a -;; + ;; + ;; a + ;; (add-stem-support ,boolean? "If set, the @code{Stem} object is included in this script's support.") (after-line-breaking ,boolean? "Dummy property, used to trigger @@ -79,9 +79,9 @@ and @code{around} behave like @code{ignore}.") grobs, this should contain only one number.") -;; -;; b -;; + ;; + ;; b + ;; (bar-extent ,number-pair? "The Y-extent of the actual bar line. This may differ from @code{Y-extent} because it does not include the dots in a repeat bar line.") @@ -168,9 +168,9 @@ stick out of its bounds?") (broken-bound-padding ,number? "The amount of padding to insert when a spanner is broken at a line break.") -;; -;; c -;; + ;; + ;; c + ;; (c0-position ,integer? "An integer indicating the position of middle@tie{}C.") (circled-tip ,boolean? "Put a circle at start/@/end of @@ -205,9 +205,9 @@ this should list the control points of a third-order B@'ezier curve.") receives this number. The following measures are numbered in increments from this initial value.") -;; -;; d -;; + ;; + ;; d + ;; (damping ,number? "Amount of beam slope damping.") (dash-definition ,pair? "List of @code{dash-elements} defining the dash structure. Each @code{dash-element} has a starting t value, @@ -248,9 +248,9 @@ elements closer together.") i.e., @code{0} = whole note, @code{1} = half note, etc.") -;; -;; e -;; + ;; + ;; e + ;; (eccentricity ,number? "How asymmetrical to make a slur. Positive means move the center to the right.") (edge-height ,pair? "A pair of numbers specifying the heights of @@ -282,9 +282,9 @@ item). In order to make a grob take up no horizontal space at all, set this to @code{(+inf.0 . -inf.0)}.") -;; -;; f -;; + ;; + ;; f + ;; (flag-count ,number? "The number of tremolo beams.") (flat-positions ,list? "Flats in key signatures are placed within the specified ranges of staff-positions. The general form @@ -423,9 +423,9 @@ read from the NonMusicalPaperColumn that begins the measure.") (full-size-change ,boolean? "Don't make a change clef smaller.") -;; -;; g -;; + ;; + ;; g + ;; (gap ,ly:dimension? "Size of a gap in a variable symbol.") (gap-count ,integer? "Number of gapped beams for tremolo.") (glissando-skip ,boolean? "Should this @code{NoteHead} be skipped @@ -446,9 +446,9 @@ etc. are already taken.") (grow-direction ,ly:dir? "Crescendo or decrescendo?") -;; -;; h -;; + ;; + ;; h + ;; (hair-thickness ,number? "Thickness of the thin line in a bar line.") (harp-pedal-details ,list? "An alist of detailed grob properties @@ -499,9 +499,9 @@ of @code{NoteColumn}s for horizontal shifting. This is used by left and one to the right of this grob.") -;; -;; i -;; + ;; + ;; i + ;; (id ,string? "An id string for the grob. Depending on the typestting backend being used, this id will be assigned to a group containing all of the stencils that comprise a given grob. For example, in the svg backend, @@ -518,9 +518,9 @@ configuration to this index, and print the respective scores.") slur quants to this position, and print the respective scores.") -;; -;; k -;; + ;; + ;; k + ;; (keep-inside-line ,boolean? "If set, this column cannot have objects sticking into the margin.") (kern ,ly:dimension? "Amount of extra white space to add. For @@ -531,9 +531,9 @@ correction amount for kneed beams. Set between @code{0} for no correction and @code{1} for full correction.") -;; -;; l -;; + ;; + ;; l + ;; (labels ,list? "List of labels (symbols) placed on a column.") (layer ,integer? "An integer which determines the order of printing objects. Objects with the lowest value of layer are drawn first, then @@ -572,9 +572,9 @@ contour.") (long-text ,markup? "Text markup. See @ruser{Formatting text}.") -;; -;; m -;; + ;; + ;; m + ;; (max-beam-connect ,integer? "Maximum number of beams to connect to beams from this stem. Further beams are typeset as beamlets.") (max-stretch ,number? "The maximum amount that this @@ -615,9 +615,9 @@ X@tie{}dimension, measured in @code{staff-space} units.") Y@tie{}dimension, measured in @code{staff-space} units.") -;; -;; n -;; + ;; + ;; n + ;; (neutral-direction ,ly:dir? "Which direction to take in the center of the staff.") (neutral-position ,number? "Position (in half staff spaces) where @@ -668,9 +668,9 @@ between 0 and 1.") easy-notation note heads.") -;; -;; o -;; + ;; + ;; o + ;; (outside-staff-horizontal-padding ,number? "By default, an outside-staff-object can be placed so that is it very close to another grob horizontally. If this property is set, the outside-staff-object @@ -702,9 +702,9 @@ of a potential collision, the grob with the smaller @code{outside-staff-priority} is closer to the staff.") -;; -;; p -;; + ;; + ;; p + ;; (packed-spacing ,boolean? "If set, the notes are spaced as tightly as possible.") (padding ,ly:dimension? "Add this much extra space between @@ -737,9 +737,9 @@ dot.") (protrusion ,number? "In an arpeggio bracket, the length of the horizontal edges.") -;; -;; r -;; + ;; + ;; r + ;; (ratio ,number? "Parameter for slur shape. The higher this number, the quicker the slur attains its @code{height-limit}.") (remove-empty ,boolean? "If set, remove group if it contains no @@ -767,9 +767,9 @@ rest when the length of a measure is between two values of in a 3/2 measure.") -;; -;; s -;; + ;; + ;; s + ;; (same-direction-correction ,number? "Optical correction amount for stems that are placed in tight configurations. This amount is used for stems with the same direction to compensate for note head to @@ -945,11 +945,11 @@ typeset. Valid choices depend on the @code{stencil} callback reading this property.") -;; -;; t -;; + ;; + ;; t + ;; (text ,markup? "Text markup. See @ruser{Formatting text}.") -;;FIXME -- Should both be the same? + ;;FIXME -- Should both be the same? (text-direction ,ly:dir? "This controls the ordering of the words. The default @code{RIGHT} is for roman text. Arabic or Hebrew should use @code{LEFT}.") @@ -970,7 +970,7 @@ line just before it would otherwise stop.") (toward-stem-shift ,number? "Amount by which scripts are shifted toward the stem if their direction coincides with the stem direction. @code{0.0} means keep the default position (centered on the note -head), @code{1.0} means centered on the stem. Interpolated values are + head), @code{1.0} means centered on the stem. Interpolated values are possible.") (transparent ,boolean? "This makes the grob invisible.") @@ -1001,7 +1001,7 @@ one below this grob.") happen?") (whiteout ,boolean? "If true, the grob is printed over a white background to white-out underlying material, if the grob is visible. - Usually #f by default.") +Usually #f by default.") (width ,ly:dimension? "The width of a grob measured in staff space.") (word-space ,ly:dimension? "Space to insert between words in diff --git a/scm/define-grobs.scm b/scm/define-grobs.scm index 4d015b7658..df94769f50 100644 --- a/scm/define-grobs.scm +++ b/scm/define-grobs.scm @@ -29,363 +29,363 @@ `( (Accidental . ( - (alteration . ,accidental-interface::calc-alteration) - (avoid-slur . inside) - (glyph-name . ,accidental-interface::glyph-name) - (glyph-name-alist . ,standard-alteration-glyph-name-alist) - (stencil . ,ly:accidental-interface::print) - (horizontal-skylines . ,(ly:make-unpure-pure-container ly:accidental-interface::horizontal-skylines)) - (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) - (X-extent . ,ly:accidental-interface::width) - (Y-extent . ,accidental-interface::height) - (meta . ((class . Item) - (interfaces . (accidental-interface - inline-accidental-interface - font-interface)))))) + (alteration . ,accidental-interface::calc-alteration) + (avoid-slur . inside) + (glyph-name . ,accidental-interface::glyph-name) + (glyph-name-alist . ,standard-alteration-glyph-name-alist) + (stencil . ,ly:accidental-interface::print) + (horizontal-skylines . ,(ly:make-unpure-pure-container ly:accidental-interface::horizontal-skylines)) + (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) + (X-extent . ,ly:accidental-interface::width) + (Y-extent . ,accidental-interface::height) + (meta . ((class . Item) + (interfaces . (accidental-interface + inline-accidental-interface + font-interface)))))) (AccidentalCautionary . ( - (alteration . ,accidental-interface::calc-alteration) - (avoid-slur . inside) - (glyph-name-alist . ,standard-alteration-glyph-name-alist) - (parenthesized . #t) - (stencil . ,ly:accidental-interface::print) - (Y-extent . ,accidental-interface::height) - (meta . ((class . Item) - (interfaces . (accidental-interface - inline-accidental-interface - font-interface)))))) + (alteration . ,accidental-interface::calc-alteration) + (avoid-slur . inside) + (glyph-name-alist . ,standard-alteration-glyph-name-alist) + (parenthesized . #t) + (stencil . ,ly:accidental-interface::print) + (Y-extent . ,accidental-interface::height) + (meta . ((class . Item) + (interfaces . (accidental-interface + inline-accidental-interface + font-interface)))))) (AccidentalPlacement . ( - (direction . ,LEFT) - (positioning-done . ,ly:accidental-placement::calc-positioning-done) + (direction . ,LEFT) + (positioning-done . ,ly:accidental-placement::calc-positioning-done) - ;; this is quite small, but it is very ugly to have - ;; accs closer to the previous note than to the next one. - (right-padding . 0.15) + ;; this is quite small, but it is very ugly to have + ;; accs closer to the previous note than to the next one. + (right-padding . 0.15) - ;; for horizontally stacked scripts. - (script-priority . -100) + ;; for horizontally stacked scripts. + (script-priority . -100) - (X-extent . ,ly:axis-group-interface::width) - (meta . ((class . Item) - (interfaces . (accidental-placement-interface)))))) + (X-extent . ,ly:axis-group-interface::width) + (meta . ((class . Item) + (interfaces . (accidental-placement-interface)))))) (AccidentalSuggestion . ( - (alteration . ,accidental-interface::calc-alteration) - (direction . ,UP) - (font-size . -2) - (glyph-name-alist . ,standard-alteration-glyph-name-alist) - (outside-staff-priority . 0) - (script-priority . 0) - (self-alignment-X . ,CENTER) - (side-axis . ,Y) - (staff-padding . 0.25) - (stencil . ,ly:accidental-interface::print) - (X-extent . ,ly:accidental-interface::width) - (X-offset . ,(ly:make-simple-closure - `(,+ - ,(ly:make-simple-closure - (list ly:self-alignment-interface::centered-on-x-parent)) - ,(ly:make-simple-closure - (list ly:self-alignment-interface::x-aligned-on-self))))) - (Y-extent . ,accidental-interface::height) - (Y-offset . ,side-position-interface::y-aligned-side) - (meta . ((class . Item) - (interfaces . (accidental-interface - accidental-suggestion-interface - font-interface - script-interface - self-alignment-interface - side-position-interface)))))) + (alteration . ,accidental-interface::calc-alteration) + (direction . ,UP) + (font-size . -2) + (glyph-name-alist . ,standard-alteration-glyph-name-alist) + (outside-staff-priority . 0) + (script-priority . 0) + (self-alignment-X . ,CENTER) + (side-axis . ,Y) + (staff-padding . 0.25) + (stencil . ,ly:accidental-interface::print) + (X-extent . ,ly:accidental-interface::width) + (X-offset . ,(ly:make-simple-closure + `(,+ + ,(ly:make-simple-closure + (list ly:self-alignment-interface::centered-on-x-parent)) + ,(ly:make-simple-closure + (list ly:self-alignment-interface::x-aligned-on-self))))) + (Y-extent . ,accidental-interface::height) + (Y-offset . ,side-position-interface::y-aligned-side) + (meta . ((class . Item) + (interfaces . (accidental-interface + accidental-suggestion-interface + font-interface + script-interface + self-alignment-interface + side-position-interface)))))) (Ambitus . ( - (axes . (,X ,Y)) - (break-align-symbol . ambitus) - (break-visibility . ,begin-of-line-visible) - (non-musical . #t) - (space-alist . ( - (cue-end-clef . (extra-space . 0.5)) - (clef . (extra-space . 0.5)) - (cue-clef . (extra-space . 0.5)) - (key-signature . (extra-space . 0.0)) - (staff-bar . (extra-space . 0.0)) - (time-signature . (extra-space . 0.0)) - (first-note . (fixed-space . 0.0)))) - (X-extent . ,ly:axis-group-interface::width) - (Y-extent . ,axis-group-interface::height) - (meta . ((class . Item) - (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) - (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) - (interfaces . (ambitus-interface - axis-group-interface - break-aligned-interface)))))) + (axes . (,X ,Y)) + (break-align-symbol . ambitus) + (break-visibility . ,begin-of-line-visible) + (non-musical . #t) + (space-alist . ( + (cue-end-clef . (extra-space . 0.5)) + (clef . (extra-space . 0.5)) + (cue-clef . (extra-space . 0.5)) + (key-signature . (extra-space . 0.0)) + (staff-bar . (extra-space . 0.0)) + (time-signature . (extra-space . 0.0)) + (first-note . (fixed-space . 0.0)))) + (X-extent . ,ly:axis-group-interface::width) + (Y-extent . ,axis-group-interface::height) + (meta . ((class . Item) + (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) + (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) + (interfaces . (ambitus-interface + axis-group-interface + break-aligned-interface)))))) (AmbitusAccidental . ( - (direction . ,LEFT) - (glyph-name-alist . ,standard-alteration-glyph-name-alist) - (padding . 0.5) - (side-axis . ,X) - (stencil . ,ly:accidental-interface::print) - (X-offset . ,ly:side-position-interface::x-aligned-side) - (Y-extent . ,accidental-interface::height) - (meta . ((class . Item) - (interfaces . (accidental-interface - break-aligned-interface - font-interface - side-position-interface)))))) + (direction . ,LEFT) + (glyph-name-alist . ,standard-alteration-glyph-name-alist) + (padding . 0.5) + (side-axis . ,X) + (stencil . ,ly:accidental-interface::print) + (X-offset . ,ly:side-position-interface::x-aligned-side) + (Y-extent . ,accidental-interface::height) + (meta . ((class . Item) + (interfaces . (accidental-interface + break-aligned-interface + font-interface + side-position-interface)))))) (AmbitusLine . ( - (gap . 0.35) - (stencil . ,ambitus::print) - (thickness . 2) - (X-offset . ,ly:self-alignment-interface::centered-on-x-parent) - (meta . ((class . Item) - (interfaces . (ambitus-interface - font-interface)))))) + (gap . 0.35) + (stencil . ,ambitus::print) + (thickness . 2) + (X-offset . ,ly:self-alignment-interface::centered-on-x-parent) + (meta . ((class . Item) + (interfaces . (ambitus-interface + font-interface)))))) (AmbitusNoteHead . ( - (duration-log . 2) - (glyph-name . ,note-head::calc-glyph-name) - (stencil . ,ly:note-head::print) - (Y-offset . ,staff-symbol-referencer::callback) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (ambitus-interface - font-interface - ledgered-interface - note-head-interface - rhythmic-head-interface - staff-symbol-referencer-interface)))))) + (duration-log . 2) + (glyph-name . ,note-head::calc-glyph-name) + (stencil . ,ly:note-head::print) + (Y-offset . ,staff-symbol-referencer::callback) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (ambitus-interface + font-interface + ledgered-interface + note-head-interface + rhythmic-head-interface + staff-symbol-referencer-interface)))))) (Arpeggio . ( - (direction . ,LEFT) - (padding . 0.5) - (positions . ,ly:arpeggio::calc-positions) - (protrusion . 0.4) - (script-priority . 0) - (side-axis . ,X) - (staff-position . 0.0) - (stencil . ,ly:arpeggio::print) - (X-extent . ,ly:arpeggio::width) - (Y-extent . ,(grob::unpure-Y-extent-from-stencil ly:arpeggio::pure-height)) - (X-offset . ,ly:side-position-interface::x-aligned-side) - (Y-offset . ,staff-symbol-referencer::callback) - (meta . ((class . Item) - (interfaces . (arpeggio-interface - font-interface - side-position-interface - staff-symbol-referencer-interface)))))) + (direction . ,LEFT) + (padding . 0.5) + (positions . ,ly:arpeggio::calc-positions) + (protrusion . 0.4) + (script-priority . 0) + (side-axis . ,X) + (staff-position . 0.0) + (stencil . ,ly:arpeggio::print) + (X-extent . ,ly:arpeggio::width) + (Y-extent . ,(grob::unpure-Y-extent-from-stencil ly:arpeggio::pure-height)) + (X-offset . ,ly:side-position-interface::x-aligned-side) + (Y-offset . ,staff-symbol-referencer::callback) + (meta . ((class . Item) + (interfaces . (arpeggio-interface + font-interface + side-position-interface + staff-symbol-referencer-interface)))))) (BalloonTextItem . ( - (annotation-balloon . #t) - (annotation-line . #t) - (extra-spacing-width . (+inf.0 . -inf.0)) - (stencil . ,ly:balloon-interface::print) - (text . ,(grob::calc-property-by-copy 'text)) - (X-offset . ,(grob::calc-property-by-copy 'X-offset)) - (Y-offset . ,(grob::calc-property-by-copy 'Y-offset)) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (balloon-interface - font-interface - text-interface)))))) + (annotation-balloon . #t) + (annotation-line . #t) + (extra-spacing-width . (+inf.0 . -inf.0)) + (stencil . ,ly:balloon-interface::print) + (text . ,(grob::calc-property-by-copy 'text)) + (X-offset . ,(grob::calc-property-by-copy 'X-offset)) + (Y-offset . ,(grob::calc-property-by-copy 'Y-offset)) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (balloon-interface + font-interface + text-interface)))))) (BarLine . ( - (allow-span-bar . #t) - (bar-extent . ,ly:bar-line::calc-bar-extent) - (break-align-anchor . ,ly:bar-line::calc-anchor) - (break-align-symbol . staff-bar) - (break-visibility . ,bar-line::calc-break-visibility) - (extra-spacing-height . ,pure-from-neighbor-interface::account-for-span-bar) - (gap . 0.4) - (glyph . "|") - (glyph-name . ,bar-line::calc-glyph-name) - - ;; - ;; Ross. page 151 lists other values, we opt for a leaner look - ;; - ;; TODO: - ;; kern should scale with line-thickness too. - (kern . 3.0) - (thin-kern . 3.0) - (hair-thickness . 1.9) - (thick-thickness . 6.0) - - (layer . 0) - (non-musical . #t) - (rounded . #f) - (space-alist . ( - (time-signature . (extra-space . 0.75)) - (custos . (minimum-space . 2.0)) - (clef . (minimum-space . 1.0)) - (key-signature . (extra-space . 1.0)) - (key-cancellation . (extra-space . 1.0)) - (first-note . (fixed-space . 1.3)) - (next-note . (semi-fixed-space . 0.9)) - (right-edge . (extra-space . 0.0)))) - (stencil . ,ly:bar-line::print) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) + (allow-span-bar . #t) + (bar-extent . ,ly:bar-line::calc-bar-extent) + (break-align-anchor . ,ly:bar-line::calc-anchor) + (break-align-symbol . staff-bar) + (break-visibility . ,bar-line::calc-break-visibility) + (extra-spacing-height . ,pure-from-neighbor-interface::account-for-span-bar) + (gap . 0.4) + (glyph . "|") + (glyph-name . ,bar-line::calc-glyph-name) + + ;; + ;; Ross. page 151 lists other values, we opt for a leaner look + ;; + ;; TODO: + ;; kern should scale with line-thickness too. + (kern . 3.0) + (thin-kern . 3.0) + (hair-thickness . 1.9) + (thick-thickness . 6.0) + + (layer . 0) + (non-musical . #t) + (rounded . #f) + (space-alist . ( + (time-signature . (extra-space . 0.75)) + (custos . (minimum-space . 2.0)) + (clef . (minimum-space . 1.0)) + (key-signature . (extra-space . 1.0)) + (key-cancellation . (extra-space . 1.0)) + (first-note . (fixed-space . 1.3)) + (next-note . (semi-fixed-space . 0.9)) + (right-edge . (extra-space . 0.0)))) + (stencil . ,ly:bar-line::print) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) (pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs))) - (interfaces . (bar-line-interface - break-aligned-interface - font-interface - pure-from-neighbor-interface)))))) + (interfaces . (bar-line-interface + break-aligned-interface + font-interface + pure-from-neighbor-interface)))))) (BarNumber . ( - (after-line-breaking . ,ly:side-position-interface::move-to-extremal-staff) - ;; want the bar number before the clef at line start. - (break-align-symbols . (left-edge staff-bar)) - - (break-visibility . ,begin-of-line-visible) - (direction . ,UP) - (extra-spacing-width . (+inf.0 . -inf.0)) - (font-family . roman) - (font-size . -2) - (non-musical . #t) - ;; w/o padding, bars numbers are not positioned over the staff as - ;; they are slightly to the left. so we add just a bit. - (horizon-padding . 0.05) - (outside-staff-priority . 100) - (padding . 1.0) - (self-alignment-X . ,RIGHT) - (side-axis . ,Y) - (stencil . ,ly:text-interface::print) - (X-offset . ,(ly:make-simple-closure - `(,+ - ,(ly:make-simple-closure - (list ly:break-alignable-interface::self-align-callback)) - ,(ly:make-simple-closure - (list ly:self-alignment-interface::x-aligned-on-self))))) - (Y-offset . ,side-position-interface::y-aligned-side) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . - ((class . Item) - (interfaces . (break-alignable-interface - font-interface - self-alignment-interface - side-position-interface - text-interface)))))) + (after-line-breaking . ,ly:side-position-interface::move-to-extremal-staff) + ;; want the bar number before the clef at line start. + (break-align-symbols . (left-edge staff-bar)) + + (break-visibility . ,begin-of-line-visible) + (direction . ,UP) + (extra-spacing-width . (+inf.0 . -inf.0)) + (font-family . roman) + (font-size . -2) + (non-musical . #t) + ;; w/o padding, bars numbers are not positioned over the staff as + ;; they are slightly to the left. so we add just a bit. + (horizon-padding . 0.05) + (outside-staff-priority . 100) + (padding . 1.0) + (self-alignment-X . ,RIGHT) + (side-axis . ,Y) + (stencil . ,ly:text-interface::print) + (X-offset . ,(ly:make-simple-closure + `(,+ + ,(ly:make-simple-closure + (list ly:break-alignable-interface::self-align-callback)) + ,(ly:make-simple-closure + (list ly:self-alignment-interface::x-aligned-on-self))))) + (Y-offset . ,side-position-interface::y-aligned-side) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . + ((class . Item) + (interfaces . (break-alignable-interface + font-interface + self-alignment-interface + side-position-interface + text-interface)))))) (BassFigure . ( - (stencil . ,ly:text-interface::print) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (bass-figure-interface - font-interface - rhythmic-grob-interface - text-interface)))))) + (stencil . ,ly:text-interface::print) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (bass-figure-interface + font-interface + rhythmic-grob-interface + text-interface)))))) (BassFigureAlignment . ( - (axes . (,Y)) - (padding . 0.2) - (positioning-done . ,ly:align-interface::align-to-minimum-distances) - (stacking-dir . ,DOWN) - (X-extent . ,ly:axis-group-interface::width) - (Y-extent . ,axis-group-interface::height) - (meta . ((class . Spanner) - (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) - (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) - (interfaces . (align-interface - axis-group-interface - bass-figure-alignment-interface)))))) + (axes . (,Y)) + (padding . 0.2) + (positioning-done . ,ly:align-interface::align-to-minimum-distances) + (stacking-dir . ,DOWN) + (X-extent . ,ly:axis-group-interface::width) + (Y-extent . ,axis-group-interface::height) + (meta . ((class . Spanner) + (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) + (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) + (interfaces . (align-interface + axis-group-interface + bass-figure-alignment-interface)))))) (BassFigureAlignmentPositioning . ( - (axes . (,Y)) - (direction . ,UP) - (padding . 0.5) - (side-axis . ,Y) - (staff-padding . 1.0) - (X-extent . ,ly:axis-group-interface::width) - (Y-extent . ,axis-group-interface::height) - (Y-offset . ,side-position-interface::y-aligned-side) - (meta . ((class . Spanner) - (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) - (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) - (interfaces . (axis-group-interface - side-position-interface)))))) + (axes . (,Y)) + (direction . ,UP) + (padding . 0.5) + (side-axis . ,Y) + (staff-padding . 1.0) + (X-extent . ,ly:axis-group-interface::width) + (Y-extent . ,axis-group-interface::height) + (Y-offset . ,side-position-interface::y-aligned-side) + (meta . ((class . Spanner) + (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) + (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) + (interfaces . (axis-group-interface + side-position-interface)))))) (BassFigureBracket . ( - (edge-height . (0.2 . 0.2)) - (stencil . ,ly:enclosing-bracket::print) - (X-extent . ,ly:enclosing-bracket::width) - (meta . ((class . Item) - (interfaces . (enclosing-bracket-interface)))))) + (edge-height . (0.2 . 0.2)) + (stencil . ,ly:enclosing-bracket::print) + (X-extent . ,ly:enclosing-bracket::width) + (meta . ((class . Item) + (interfaces . (enclosing-bracket-interface)))))) (BassFigureContinuation . ( - (stencil . ,ly:figured-bass-continuation::print) - (Y-offset . ,ly:figured-bass-continuation::center-on-figures) - (meta . ((class . Spanner) - (interfaces . (figured-bass-continuation-interface)))))) + (stencil . ,ly:figured-bass-continuation::print) + (Y-offset . ,ly:figured-bass-continuation::center-on-figures) + (meta . ((class . Spanner) + (interfaces . (figured-bass-continuation-interface)))))) (BassFigureLine . ( - (adjacent-pure-heights . ,ly:axis-group-interface::adjacent-pure-heights) - (axes . (,Y)) - (vertical-skylines . ,ly:axis-group-interface::calc-skylines) - (X-extent . ,ly:axis-group-interface::width) - (Y-extent . ,axis-group-interface::height) - (meta . ((class . Spanner) - (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) - (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) - (interfaces . (axis-group-interface)))))) + (adjacent-pure-heights . ,ly:axis-group-interface::adjacent-pure-heights) + (axes . (,Y)) + (vertical-skylines . ,ly:axis-group-interface::calc-skylines) + (X-extent . ,ly:axis-group-interface::width) + (Y-extent . ,axis-group-interface::height) + (meta . ((class . Spanner) + (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) + (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) + (interfaces . (axis-group-interface)))))) (Beam . ( - ;; todo: clean this up a bit: the list is getting - ;; rather long. - (auto-knee-gap . 5.5) - (beam-segments . ,ly:beam::calc-beam-segments) - (beam-thickness . 0.48) ; in staff-space - - ;; We have some unreferenced problems here. - ;; - ;; If we shorten beamed stems less than normal stems (1 staff-space), - ;; or high order less than 8th beams, patterns like - ;; c''4 [c''8 c''] c''4 [c''16 c] - ;; are ugly (different stem lengths). - ;; - ;; But if we shorten 16th beams as much as 8th beams, a single - ;; forced 16th beam looks *very* short. - - ;; We choose to shorten 8th beams the same as single stems, - ;; and high order beams less than 8th beams, so that all - ;; isolated shortened beams look nice and a bit shortened, - ;; sadly possibly breaking patterns with high order beams. - (beamed-stem-shorten . (1.0 0.5 0.25)) - - (beaming . ,ly:beam::calc-beaming) - (clip-edges . #t) - (collision-interfaces . (beam-interface - clef-interface - clef-modifier-interface - flag-interface - inline-accidental-interface - key-signature-interface - note-head-interface - stem-interface - time-signature-interface)) - (cross-staff . ,ly:beam::calc-cross-staff) - (damping . 1) - (details + ;; todo: clean this up a bit: the list is getting + ;; rather long. + (auto-knee-gap . 5.5) + (beam-segments . ,ly:beam::calc-beam-segments) + (beam-thickness . 0.48) ; in staff-space + + ;; We have some unreferenced problems here. + ;; + ;; If we shorten beamed stems less than normal stems (1 staff-space), + ;; or high order less than 8th beams, patterns like + ;; c''4 [c''8 c''] c''4 [c''16 c] + ;; are ugly (different stem lengths). + ;; + ;; But if we shorten 16th beams as much as 8th beams, a single + ;; forced 16th beam looks *very* short. + + ;; We choose to shorten 8th beams the same as single stems, + ;; and high order beams less than 8th beams, so that all + ;; isolated shortened beams look nice and a bit shortened, + ;; sadly possibly breaking patterns with high order beams. + (beamed-stem-shorten . (1.0 0.5 0.25)) + + (beaming . ,ly:beam::calc-beaming) + (clip-edges . #t) + (collision-interfaces . (beam-interface + clef-interface + clef-modifier-interface + flag-interface + inline-accidental-interface + key-signature-interface + note-head-interface + stem-interface + time-signature-interface)) + (cross-staff . ,ly:beam::calc-cross-staff) + (damping . 1) + (details .( (secondary-beam-demerit . 10) (stem-length-demerit-factor . 5) @@ -396,1010 +396,1010 @@ (hint-direction-penalty . 20) (musical-direction-factor . 400) (ideal-slope-factor . 10) - (collision-penalty . 500) - (collision-padding . 0.35) + (collision-penalty . 500) + (collision-padding . 0.35) (round-to-zero-slope . 0.02))) - (direction . ,ly:beam::calc-direction) - - (normalized-endpoints . ,ly:spanner::calc-normalized-endpoints) - ;; only for debugging. - (font-family . roman) - - (beam-gap . ,ly:beam::calc-beam-gap) - (minimum-length . ,ly:beam::calc-minimum-length) - (neutral-direction . ,DOWN) - (positions . ,beam::place-broken-parts-individually) - (springs-and-rods . ,ly:beam::calc-springs-and-rods) - (X-positions . ,ly:beam::calc-x-positions) + (direction . ,ly:beam::calc-direction) + + (normalized-endpoints . ,ly:spanner::calc-normalized-endpoints) + ;; only for debugging. + (font-family . roman) + + (beam-gap . ,ly:beam::calc-beam-gap) + (minimum-length . ,ly:beam::calc-minimum-length) + (neutral-direction . ,DOWN) + (positions . ,beam::place-broken-parts-individually) + (springs-and-rods . ,ly:beam::calc-springs-and-rods) + (X-positions . ,ly:beam::calc-x-positions) (transparent . ,(grob::inherit-parent-property X 'transparent)) - ;; this is a hack to set stem lengths, if positions is set. - (quantized-positions . ,ly:beam::set-stem-lengths) + ;; this is a hack to set stem lengths, if positions is set. + (quantized-positions . ,ly:beam::set-stem-lengths) - (shorten . ,ly:beam::calc-stem-shorten) - (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) - (stencil . ,ly:beam::print) + (shorten . ,ly:beam::calc-stem-shorten) + (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) + (stencil . ,ly:beam::print) - (meta . ((class . Spanner) - (object-callbacks . ((normal-stems . ,ly:beam::calc-normal-stems))) - (interfaces . (beam-interface - font-interface - staff-symbol-referencer-interface - unbreakable-spanner-interface)))))) + (meta . ((class . Spanner) + (object-callbacks . ((normal-stems . ,ly:beam::calc-normal-stems))) + (interfaces . (beam-interface + font-interface + staff-symbol-referencer-interface + unbreakable-spanner-interface)))))) (BendAfter . ( - (minimum-length . 0.5) - (stencil . ,bend::print) - (thickness . 2.0) - (meta . ((class . Spanner) - (interfaces . (bend-after-interface - spanner-interface)))))) + (minimum-length . 0.5) + (stencil . ,bend::print) + (thickness . 2.0) + (meta . ((class . Spanner) + (interfaces . (bend-after-interface + spanner-interface)))))) (BreakAlignGroup . ( - (axes . (,X)) - (break-align-anchor . ,ly:break-aligned-interface::calc-average-anchor) - (break-visibility . ,ly:break-aligned-interface::calc-break-visibility) - (X-extent . ,ly:axis-group-interface::width) - (meta . ((class . Item) - (interfaces . (axis-group-interface - break-aligned-interface)))))) + (axes . (,X)) + (break-align-anchor . ,ly:break-aligned-interface::calc-average-anchor) + (break-visibility . ,ly:break-aligned-interface::calc-break-visibility) + (X-extent . ,ly:axis-group-interface::width) + (meta . ((class . Item) + (interfaces . (axis-group-interface + break-aligned-interface)))))) (BreakAlignment . ( - (axes . (,X)) - (break-align-orders . ;; end of line - #(( - left-edge - cue-end-clef - ambitus - breathing-sign - clef - cue-clef - staff-bar - key-cancellation - key-signature - time-signature - custos) - - ;; unbroken - ( - left-edge - cue-end-clef - ambitus - breathing-sign - clef - cue-clef - staff-bar - key-cancellation - key-signature - time-signature - custos) - - ;; begin of line - ( - left-edge - ambitus - breathing-sign - clef - key-cancellation - key-signature - time-signature - staff-bar - cue-clef - custos))) - (non-musical . #t) - (positioning-done . ,ly:break-alignment-interface::calc-positioning-done) - (stacking-dir . 1) - (X-extent . ,ly:axis-group-interface::width) - (meta . ((class . Item) - (interfaces . (axis-group-interface - break-alignment-interface)))))) + (axes . (,X)) + (break-align-orders . ;; end of line + #(( + left-edge + cue-end-clef + ambitus + breathing-sign + clef + cue-clef + staff-bar + key-cancellation + key-signature + time-signature + custos) + + ;; unbroken + ( + left-edge + cue-end-clef + ambitus + breathing-sign + clef + cue-clef + staff-bar + key-cancellation + key-signature + time-signature + custos) + + ;; begin of line + ( + left-edge + ambitus + breathing-sign + clef + key-cancellation + key-signature + time-signature + staff-bar + cue-clef + custos))) + (non-musical . #t) + (positioning-done . ,ly:break-alignment-interface::calc-positioning-done) + (stacking-dir . 1) + (X-extent . ,ly:axis-group-interface::width) + (meta . ((class . Item) + (interfaces . (axis-group-interface + break-alignment-interface)))))) (BreathingSign . ( - (break-align-symbol . breathing-sign) - (break-visibility . ,begin-of-line-invisible) - (non-musical . #t) - (space-alist . ( - (ambitus . (extra-space . 2.0)) - (custos . (minimum-space . 1.0)) - (key-signature . (minimum-space . 1.5)) - (time-signature . (minimum-space . 1.5)) - (staff-bar . (minimum-space . 1.5)) - (clef . (minimum-space . 2.0)) - (cue-clef . (minimum-space . 2.0)) - (cue-end-clef . (minimum-space . 2.0)) - (first-note . (fixed-space . 1.0)) ;huh? - (right-edge . (extra-space . 0.1)))) - (stencil . ,ly:text-interface::print) - (text . ,(make-musicglyph-markup "scripts.rcomma")) - (Y-offset . ,ly:breathing-sign::offset-callback) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (break-aligned-interface - breathing-sign-interface - font-interface - text-interface)))))) + (break-align-symbol . breathing-sign) + (break-visibility . ,begin-of-line-invisible) + (non-musical . #t) + (space-alist . ( + (ambitus . (extra-space . 2.0)) + (custos . (minimum-space . 1.0)) + (key-signature . (minimum-space . 1.5)) + (time-signature . (minimum-space . 1.5)) + (staff-bar . (minimum-space . 1.5)) + (clef . (minimum-space . 2.0)) + (cue-clef . (minimum-space . 2.0)) + (cue-end-clef . (minimum-space . 2.0)) + (first-note . (fixed-space . 1.0)) ;huh? + (right-edge . (extra-space . 0.1)))) + (stencil . ,ly:text-interface::print) + (text . ,(make-musicglyph-markup "scripts.rcomma")) + (Y-offset . ,ly:breathing-sign::offset-callback) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (break-aligned-interface + breathing-sign-interface + font-interface + text-interface)))))) (ChordName . ( - (after-line-breaking . ,ly:chord-name::after-line-breaking) - (font-family . sans) - (font-size . 1.5) - (stencil . ,ly:text-interface::print) - (extra-spacing-height . (0.2 . -0.2)) - (extra-spacing-width . (-0.5 . 0.5)) - (word-space . 0.0) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (chord-name-interface - font-interface - rhythmic-grob-interface - text-interface)))))) + (after-line-breaking . ,ly:chord-name::after-line-breaking) + (font-family . sans) + (font-size . 1.5) + (stencil . ,ly:text-interface::print) + (extra-spacing-height . (0.2 . -0.2)) + (extra-spacing-width . (-0.5 . 0.5)) + (word-space . 0.0) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (chord-name-interface + font-interface + rhythmic-grob-interface + text-interface)))))) (Clef . ( - (avoid-slur . inside) - (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor) - (break-align-anchor-alignment . ,RIGHT) - (break-align-symbol . clef) - (break-visibility . ,begin-of-line-visible) - (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line) - (glyph-name . ,ly:clef::calc-glyph-name) - (non-musical . #t) - (space-alist . ((cue-clef . (extra-space . 2.0)) - (staff-bar . (extra-space . 0.7)) - (key-cancellation . (minimum-space . 3.5)) - (key-signature . (minimum-space . 3.5)) - (time-signature . (minimum-space . 4.2)) - (first-note . (minimum-fixed-space . 5.0)) - (next-note . (extra-space . 1.0)) - (right-edge . (extra-space . 0.5)))) - (stencil . ,ly:clef::print) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - (Y-offset . ,staff-symbol-referencer::callback) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) + (avoid-slur . inside) + (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor) + (break-align-anchor-alignment . ,RIGHT) + (break-align-symbol . clef) + (break-visibility . ,begin-of-line-visible) + (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line) + (glyph-name . ,ly:clef::calc-glyph-name) + (non-musical . #t) + (space-alist . ((cue-clef . (extra-space . 2.0)) + (staff-bar . (extra-space . 0.7)) + (key-cancellation . (minimum-space . 3.5)) + (key-signature . (minimum-space . 3.5)) + (time-signature . (minimum-space . 4.2)) + (first-note . (minimum-fixed-space . 5.0)) + (next-note . (extra-space . 1.0)) + (right-edge . (extra-space . 0.5)))) + (stencil . ,ly:clef::print) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + (Y-offset . ,staff-symbol-referencer::callback) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) (pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs))) - (interfaces . (break-aligned-interface - clef-interface - font-interface - pure-from-neighbor-interface - staff-symbol-referencer-interface)))))) + (interfaces . (break-aligned-interface + clef-interface + font-interface + pure-from-neighbor-interface + staff-symbol-referencer-interface)))))) (ClefModifier . ( - (break-visibility . ,(grob::inherit-parent-property + (break-visibility . ,(grob::inherit-parent-property X 'break-visibility)) - (font-shape . italic) - (font-size . -4) + (font-shape . italic) + (font-size . -4) (transparent . ,(grob::inherit-parent-property X 'transparent)) (color . ,(grob::inherit-parent-property X 'color)) - (self-alignment-X . ,CENTER) - (staff-padding . 0.2) - (stencil . ,ly:text-interface::print) - (X-offset . ,(ly:make-simple-closure - `(,+ - ,(ly:make-simple-closure - (list ly:self-alignment-interface::x-aligned-on-self)) - ,(ly:make-simple-closure - (list ly:self-alignment-interface::centered-on-x-parent))))) - (Y-offset . ,side-position-interface::y-aligned-side) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (clef-modifier-interface - font-interface - self-alignment-interface - side-position-interface - text-interface)))))) + (self-alignment-X . ,CENTER) + (staff-padding . 0.2) + (stencil . ,ly:text-interface::print) + (X-offset . ,(ly:make-simple-closure + `(,+ + ,(ly:make-simple-closure + (list ly:self-alignment-interface::x-aligned-on-self)) + ,(ly:make-simple-closure + (list ly:self-alignment-interface::centered-on-x-parent))))) + (Y-offset . ,side-position-interface::y-aligned-side) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (clef-modifier-interface + font-interface + self-alignment-interface + side-position-interface + text-interface)))))) (ClusterSpanner . ( - (cross-staff . ,ly:cluster::calc-cross-staff) - (minimum-length . 0.0) - (padding . 0.25) - (springs-and-rods . ,ly:spanner::set-spacing-rods) - (stencil . ,ly:cluster::print) - (style . ramp) - (meta . ((class . Spanner) - (interfaces . (cluster-interface)))))) + (cross-staff . ,ly:cluster::calc-cross-staff) + (minimum-length . 0.0) + (padding . 0.25) + (springs-and-rods . ,ly:spanner::set-spacing-rods) + (stencil . ,ly:cluster::print) + (style . ramp) + (meta . ((class . Spanner) + (interfaces . (cluster-interface)))))) (ClusterSpannerBeacon . ( - (Y-extent . ,ly:cluster-beacon::height) - (meta . ((class . Item) - (interfaces . (cluster-beacon-interface - rhythmic-grob-interface)))))) + (Y-extent . ,ly:cluster-beacon::height) + (meta . ((class . Item) + (interfaces . (cluster-beacon-interface + rhythmic-grob-interface)))))) (CombineTextScript . ( - (avoid-slur . outside) - (baseline-skip . 2) - (direction . ,UP) - (extra-spacing-width . (+inf.0 . -inf.0)) - (font-series . bold) - (outside-staff-priority . 450) - (padding . 0.5) - (script-priority . 200) - (side-axis . ,Y) - (staff-padding . 0.5) - ;; todo: add X self alignment? - (stencil . ,ly:text-interface::print) - (X-offset . ,ly:self-alignment-interface::x-aligned-on-self) - (Y-offset . ,side-position-interface::y-aligned-side) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (font-interface - side-position-interface - text-interface - text-script-interface)))))) + (avoid-slur . outside) + (baseline-skip . 2) + (direction . ,UP) + (extra-spacing-width . (+inf.0 . -inf.0)) + (font-series . bold) + (outside-staff-priority . 450) + (padding . 0.5) + (script-priority . 200) + (side-axis . ,Y) + (staff-padding . 0.5) + ;; todo: add X self alignment? + (stencil . ,ly:text-interface::print) + (X-offset . ,ly:self-alignment-interface::x-aligned-on-self) + (Y-offset . ,side-position-interface::y-aligned-side) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (font-interface + side-position-interface + text-interface + text-script-interface)))))) (CueClef . ( - (avoid-slur . inside) - (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor) - (break-align-symbol . cue-clef) - (break-visibility . ,begin-of-line-visible) - (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line) - (font-size . -4) - (glyph-name . ,ly:clef::calc-glyph-name) - (non-musical . #t) - (full-size-change . #t) - (space-alist . ((staff-bar . (minimum-space . 2.7)) - (key-cancellation . (minimum-space . 3.5)) - (key-signature . (minimum-space . 3.5)) - (time-signature . (minimum-space . 4.2)) - (custos . (minimum-space . 0.0)) - (first-note . (minimum-fixed-space . 3.0)) - (next-note . (extra-space . 1.0)) - (right-edge . (extra-space . 0.5)))) - (stencil . ,ly:clef::print) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - (Y-offset . ,staff-symbol-referencer::callback) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) + (avoid-slur . inside) + (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor) + (break-align-symbol . cue-clef) + (break-visibility . ,begin-of-line-visible) + (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line) + (font-size . -4) + (glyph-name . ,ly:clef::calc-glyph-name) + (non-musical . #t) + (full-size-change . #t) + (space-alist . ((staff-bar . (minimum-space . 2.7)) + (key-cancellation . (minimum-space . 3.5)) + (key-signature . (minimum-space . 3.5)) + (time-signature . (minimum-space . 4.2)) + (custos . (minimum-space . 0.0)) + (first-note . (minimum-fixed-space . 3.0)) + (next-note . (extra-space . 1.0)) + (right-edge . (extra-space . 0.5)))) + (stencil . ,ly:clef::print) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + (Y-offset . ,staff-symbol-referencer::callback) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) (pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs))) - (interfaces . (break-aligned-interface - clef-interface - font-interface - pure-from-neighbor-interface - staff-symbol-referencer-interface)))))) + (interfaces . (break-aligned-interface + clef-interface + font-interface + pure-from-neighbor-interface + staff-symbol-referencer-interface)))))) (CueEndClef . ( - (avoid-slur . inside) - (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor) - (break-align-symbol . cue-end-clef) - (break-visibility . ,begin-of-line-invisible) - (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line) - (font-size . -4) - (glyph-name . ,ly:clef::calc-glyph-name) - (non-musical . #t) - (full-size-change . #t) - (space-alist . ((clef . (extra-space . 0.7)) - (cue-clef . (extra-space . 0.7)) - (staff-bar . (extra-space . 0.7)) - (key-cancellation . (minimum-space . 3.5)) - (key-signature . (minimum-space . 3.5)) - (time-signature . (minimum-space . 4.2)) - (first-note . (minimum-fixed-space . 5.0)) - (next-note . (extra-space . 1.0)) - (right-edge . (extra-space . 0.5)))) - (stencil . ,ly:clef::print) - (Y-offset . ,staff-symbol-referencer::callback) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) + (avoid-slur . inside) + (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor) + (break-align-symbol . cue-end-clef) + (break-visibility . ,begin-of-line-invisible) + (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line) + (font-size . -4) + (glyph-name . ,ly:clef::calc-glyph-name) + (non-musical . #t) + (full-size-change . #t) + (space-alist . ((clef . (extra-space . 0.7)) + (cue-clef . (extra-space . 0.7)) + (staff-bar . (extra-space . 0.7)) + (key-cancellation . (minimum-space . 3.5)) + (key-signature . (minimum-space . 3.5)) + (time-signature . (minimum-space . 4.2)) + (first-note . (minimum-fixed-space . 5.0)) + (next-note . (extra-space . 1.0)) + (right-edge . (extra-space . 0.5)))) + (stencil . ,ly:clef::print) + (Y-offset . ,staff-symbol-referencer::callback) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) (pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs))) - (interfaces . (break-aligned-interface - clef-interface - font-interface - pure-from-neighbor-interface - staff-symbol-referencer-interface)))))) + (interfaces . (break-aligned-interface + clef-interface + font-interface + pure-from-neighbor-interface + staff-symbol-referencer-interface)))))) (Custos . ( - (break-align-symbol . custos) - (break-visibility . ,end-of-line-visible) - (neutral-direction . ,DOWN) - (non-musical . #t) - (space-alist . ( - (first-note . (minimum-fixed-space . 0.0)) - (right-edge . (extra-space . 0.1)))) - (stencil . ,ly:custos::print) - (style . vaticana) - (Y-offset . ,staff-symbol-referencer::callback) - (meta . ((class . Item) - (interfaces . (break-aligned-interface - custos-interface - font-interface - staff-symbol-referencer-interface)))))) + (break-align-symbol . custos) + (break-visibility . ,end-of-line-visible) + (neutral-direction . ,DOWN) + (non-musical . #t) + (space-alist . ( + (first-note . (minimum-fixed-space . 0.0)) + (right-edge . (extra-space . 0.1)))) + (stencil . ,ly:custos::print) + (style . vaticana) + (Y-offset . ,staff-symbol-referencer::callback) + (meta . ((class . Item) + (interfaces . (break-aligned-interface + custos-interface + font-interface + staff-symbol-referencer-interface)))))) (DotColumn . ( - (axes . (,X)) - (direction . ,RIGHT) - (positioning-done . ,ly:dot-column::calc-positioning-done) - (X-extent . ,ly:axis-group-interface::width) - (meta . ((class . Item) - (interfaces . (axis-group-interface - dot-column-interface)))))) + (axes . (,X)) + (direction . ,RIGHT) + (positioning-done . ,ly:dot-column::calc-positioning-done) + (X-extent . ,ly:axis-group-interface::width) + (meta . ((class . Item) + (interfaces . (axis-group-interface + dot-column-interface)))))) (Dots . ( - (avoid-slur . inside) - (dot-count . ,dots::calc-dot-count) - (staff-position . ,dots::calc-staff-position) - (stencil . ,ly:dots::print) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (extra-spacing-height . (-0.5 . 0.5)) - (meta . ((class . Item) - (interfaces . (dots-interface - font-interface - staff-symbol-referencer-interface)))))) + (avoid-slur . inside) + (dot-count . ,dots::calc-dot-count) + (staff-position . ,dots::calc-staff-position) + (stencil . ,ly:dots::print) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (extra-spacing-height . (-0.5 . 0.5)) + (meta . ((class . Item) + (interfaces . (dots-interface + font-interface + staff-symbol-referencer-interface)))))) (DoublePercentRepeat . ( - (break-align-symbol . staff-bar) - (break-visibility . ,begin-of-line-invisible) - (dot-negative-kern . 0.75) - (font-encoding . fetaMusic) - (non-musical . #t) - (slash-negative-kern . 1.6) - (slope . 1.0) - (stencil . ,ly:percent-repeat-item-interface::double-percent) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (thickness . 0.48) - (meta . ((class . Item) - (interfaces . (break-aligned-interface - font-interface - percent-repeat-interface - percent-repeat-item-interface)))))) + (break-align-symbol . staff-bar) + (break-visibility . ,begin-of-line-invisible) + (dot-negative-kern . 0.75) + (font-encoding . fetaMusic) + (non-musical . #t) + (slash-negative-kern . 1.6) + (slope . 1.0) + (stencil . ,ly:percent-repeat-item-interface::double-percent) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (thickness . 0.48) + (meta . ((class . Item) + (interfaces . (break-aligned-interface + font-interface + percent-repeat-interface + percent-repeat-item-interface)))))) (DoublePercentRepeatCounter . ( - (direction . ,UP) - (font-encoding . fetaText) - (font-size . -2) - (padding . 0.2) - (self-alignment-X . ,CENTER) - (side-axis . ,Y) - (staff-padding . 0.25) - (stencil . ,ly:text-interface::print) - (X-offset . ,(ly:make-simple-closure - `(,+ - ,(ly:make-simple-closure - (list ly:self-alignment-interface::centered-on-y-parent)) - ,(ly:make-simple-closure - (list ly:self-alignment-interface::x-aligned-on-self))))) - (Y-offset . ,side-position-interface::y-aligned-side) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (font-interface - percent-repeat-interface - percent-repeat-item-interface - self-alignment-interface - side-position-interface - text-interface)))))) + (direction . ,UP) + (font-encoding . fetaText) + (font-size . -2) + (padding . 0.2) + (self-alignment-X . ,CENTER) + (side-axis . ,Y) + (staff-padding . 0.25) + (stencil . ,ly:text-interface::print) + (X-offset . ,(ly:make-simple-closure + `(,+ + ,(ly:make-simple-closure + (list ly:self-alignment-interface::centered-on-y-parent)) + ,(ly:make-simple-closure + (list ly:self-alignment-interface::x-aligned-on-self))))) + (Y-offset . ,side-position-interface::y-aligned-side) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (font-interface + percent-repeat-interface + percent-repeat-item-interface + self-alignment-interface + side-position-interface + text-interface)))))) (DoubleRepeatSlash . ( - (dot-negative-kern . 0.75) - (font-encoding . fetaMusic) - (slash-negative-kern . 1.6) - (slope . 1.0) - (stencil . ,ly:percent-repeat-item-interface::beat-slash) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (thickness . 0.48) - (meta . ((class . Item) - (interfaces . (font-interface - percent-repeat-interface - percent-repeat-item-interface - rhythmic-grob-interface)))))) + (dot-negative-kern . 0.75) + (font-encoding . fetaMusic) + (slash-negative-kern . 1.6) + (slope . 1.0) + (stencil . ,ly:percent-repeat-item-interface::beat-slash) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (thickness . 0.48) + (meta . ((class . Item) + (interfaces . (font-interface + percent-repeat-interface + percent-repeat-item-interface + rhythmic-grob-interface)))))) (DynamicLineSpanner . ( - (axes . (,Y)) - (cross-staff . ,ly:side-position-interface::calc-cross-staff) - (direction . ,DOWN) - (minimum-space . 1.2) - (outside-staff-priority . 250) - (outside-staff-padding . 0.6) - (padding . 0.6) - (side-axis . ,Y) - (slur-padding . 0.3) - (staff-padding . 0.1) - (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils) - (X-extent . ,ly:axis-group-interface::width) - (Y-extent . ,axis-group-interface::height) - (Y-offset . ,side-position-interface::y-aligned-side) - (meta . ((class . Spanner) - (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) - (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) - (interfaces . (axis-group-interface - dynamic-interface - dynamic-line-spanner-interface - side-position-interface)))))) + (axes . (,Y)) + (cross-staff . ,ly:side-position-interface::calc-cross-staff) + (direction . ,DOWN) + (minimum-space . 1.2) + (outside-staff-priority . 250) + (outside-staff-padding . 0.6) + (padding . 0.6) + (side-axis . ,Y) + (slur-padding . 0.3) + (staff-padding . 0.1) + (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils) + (X-extent . ,ly:axis-group-interface::width) + (Y-extent . ,axis-group-interface::height) + (Y-offset . ,side-position-interface::y-aligned-side) + (meta . ((class . Spanner) + (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) + (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) + (interfaces . (axis-group-interface + dynamic-interface + dynamic-line-spanner-interface + side-position-interface)))))) (DynamicText . ( - ;; todo. - - (collision-bias . -2.0) - (collision-padding . 0.5) - (direction . ,ly:script-interface::calc-direction) - (extra-spacing-width . (+inf.0 . -inf.0)) - (font-encoding . fetaText) - (font-series . bold) - (font-shape . italic) - (positioning-done . ,ly:script-interface::calc-positioning-done) - (right-padding . 0.5) - (self-alignment-X . ,CENTER) - (self-alignment-Y . ,CENTER) - (stencil . ,ly:text-interface::print) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (X-offset . ,ly:self-alignment-interface::x-aligned-on-self) - (Y-offset . ,self-alignment-interface::y-aligned-on-self) - (meta . ((class . Item) - (interfaces . (dynamic-interface - dynamic-text-interface - font-interface - script-interface - self-alignment-interface - text-interface)))))) + ;; todo. + + (collision-bias . -2.0) + (collision-padding . 0.5) + (direction . ,ly:script-interface::calc-direction) + (extra-spacing-width . (+inf.0 . -inf.0)) + (font-encoding . fetaText) + (font-series . bold) + (font-shape . italic) + (positioning-done . ,ly:script-interface::calc-positioning-done) + (right-padding . 0.5) + (self-alignment-X . ,CENTER) + (self-alignment-Y . ,CENTER) + (stencil . ,ly:text-interface::print) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (X-offset . ,ly:self-alignment-interface::x-aligned-on-self) + (Y-offset . ,self-alignment-interface::y-aligned-on-self) + (meta . ((class . Item) + (interfaces . (dynamic-interface + dynamic-text-interface + font-interface + script-interface + self-alignment-interface + text-interface)))))) (DynamicTextSpanner . ( - (before-line-breaking . ,dynamic-text-spanner::before-line-breaking) - (bound-details . ((right . ((attach-dir . ,LEFT) - (Y . 0) - (padding . 0.75) - )) - (right-broken . ((attach-dir . ,RIGHT) - (padding . 0.0) - )) - - (left . ((attach-dir . ,LEFT) - (Y . 0) - (stencil-offset . (-0.75 . -0.5)) - (padding . 0.75) - )) - (left-broken . ((attach-dir . ,RIGHT) - )) - )) - (dash-fraction . 0.2) - (dash-period . 3.0) - - ;; rather ugh with NCSB - ;; (font-series . bold) - (font-shape . italic) - - ;; need to blend with dynamic texts. - (font-size . 1) - - (left-bound-info . ,ly:line-spanner::calc-left-bound-info-and-text) - - (minimum-length . 2.0) - ;; make sure the spanner doesn't get too close to notes - (minimum-Y-extent . (-1 . 1)) - - (right-bound-info . ,ly:line-spanner::calc-right-bound-info) - (skyline-horizontal-padding . 0.2) - (springs-and-rods . ,ly:spanner::set-spacing-rods) - (stencil . ,ly:line-spanner::print) - (style . dashed-line) - (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) - (meta . ((class . Spanner) - (interfaces . (dynamic-interface - dynamic-text-spanner-interface - font-interface - line-interface - line-spanner-interface - spanner-interface - text-interface)))))) + (before-line-breaking . ,dynamic-text-spanner::before-line-breaking) + (bound-details . ((right . ((attach-dir . ,LEFT) + (Y . 0) + (padding . 0.75) + )) + (right-broken . ((attach-dir . ,RIGHT) + (padding . 0.0) + )) + + (left . ((attach-dir . ,LEFT) + (Y . 0) + (stencil-offset . (-0.75 . -0.5)) + (padding . 0.75) + )) + (left-broken . ((attach-dir . ,RIGHT) + )) + )) + (dash-fraction . 0.2) + (dash-period . 3.0) + + ;; rather ugh with NCSB + ;; (font-series . bold) + (font-shape . italic) + + ;; need to blend with dynamic texts. + (font-size . 1) + + (left-bound-info . ,ly:line-spanner::calc-left-bound-info-and-text) + + (minimum-length . 2.0) + ;; make sure the spanner doesn't get too close to notes + (minimum-Y-extent . (-1 . 1)) + + (right-bound-info . ,ly:line-spanner::calc-right-bound-info) + (skyline-horizontal-padding . 0.2) + (springs-and-rods . ,ly:spanner::set-spacing-rods) + (stencil . ,ly:line-spanner::print) + (style . dashed-line) + (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) + (meta . ((class . Spanner) + (interfaces . (dynamic-interface + dynamic-text-spanner-interface + font-interface + line-interface + line-spanner-interface + spanner-interface + text-interface)))))) (Episema . ( - (bound-details . ((left . ((Y . 0) - (padding . 0) - (attach-dir . ,LEFT) - )) - (right . ((Y . 0) - (padding . 0) - (attach-dir . ,RIGHT) - )) - )) - (direction . ,UP) - (left-bound-info . ,ly:line-spanner::calc-left-bound-info) - (quantize-position . #t) - (right-bound-info . ,ly:line-spanner::calc-right-bound-info) - (side-axis . ,Y) - (stencil . ,ly:line-spanner::print) - (style . line) - (Y-offset . ,side-position-interface::y-aligned-side) - (meta . ((class . Spanner) - (interfaces . (episema-interface - font-interface - line-interface - line-spanner-interface - side-position-interface)))))) + (bound-details . ((left . ((Y . 0) + (padding . 0) + (attach-dir . ,LEFT) + )) + (right . ((Y . 0) + (padding . 0) + (attach-dir . ,RIGHT) + )) + )) + (direction . ,UP) + (left-bound-info . ,ly:line-spanner::calc-left-bound-info) + (quantize-position . #t) + (right-bound-info . ,ly:line-spanner::calc-right-bound-info) + (side-axis . ,Y) + (stencil . ,ly:line-spanner::print) + (style . line) + (Y-offset . ,side-position-interface::y-aligned-side) + (meta . ((class . Spanner) + (interfaces . (episema-interface + font-interface + line-interface + line-spanner-interface + side-position-interface)))))) (Fingering . ( - ;; sync with TextScript (?) - (add-stem-support . ,only-if-beamed) - (avoid-slur . around) - (cross-staff . ,script-or-side-position-cross-staff) - (direction . ,ly:script-interface::calc-direction) - (font-encoding . fetaText) - (font-size . -5) ; don't overlap when next to heads. - (padding . 0.5) - (positioning-done . ,ly:script-interface::calc-positioning-done) - (script-priority . 100) - (self-alignment-X . ,CENTER) - (self-alignment-Y . ,CENTER) - (slur-padding . 0.2) - (staff-padding . 0.5) - (stencil . ,ly:text-interface::print) - (text . ,fingering::calc-text) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (finger-interface - font-interface - self-alignment-interface - side-position-interface - text-interface - text-script-interface)))))) + ;; sync with TextScript (?) + (add-stem-support . ,only-if-beamed) + (avoid-slur . around) + (cross-staff . ,script-or-side-position-cross-staff) + (direction . ,ly:script-interface::calc-direction) + (font-encoding . fetaText) + (font-size . -5) ; don't overlap when next to heads. + (padding . 0.5) + (positioning-done . ,ly:script-interface::calc-positioning-done) + (script-priority . 100) + (self-alignment-X . ,CENTER) + (self-alignment-Y . ,CENTER) + (slur-padding . 0.2) + (staff-padding . 0.5) + (stencil . ,ly:text-interface::print) + (text . ,fingering::calc-text) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (finger-interface + font-interface + self-alignment-interface + side-position-interface + text-interface + text-script-interface)))))) (FingeringColumn . ( - (padding . 0.2) - (positioning-done . ,ly:fingering-column::calc-positioning-done) - (snap-radius . 0.3) - (meta . ((class . Item) - (interfaces . (fingering-column-interface)))))) + (padding . 0.2) + (positioning-done . ,ly:fingering-column::calc-positioning-done) + (snap-radius . 0.3) + (meta . ((class . Item) + (interfaces . (fingering-column-interface)))))) (Flag . ( - (glyph-name . ,ly:flag::glyph-name) - (stencil . ,ly:flag::print) - (X-extent . ,ly:flag::width) - (X-offset . ,ly:flag::calc-x-offset) - (Y-offset . ,(ly:make-unpure-pure-container ly:flag::calc-y-offset ly:flag::pure-calc-y-offset)) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - (meta . ((class . Item) - (interfaces . (flag-interface + (glyph-name . ,ly:flag::glyph-name) + (stencil . ,ly:flag::print) + (X-extent . ,ly:flag::width) + (X-offset . ,ly:flag::calc-x-offset) + (Y-offset . ,(ly:make-unpure-pure-container ly:flag::calc-y-offset ly:flag::pure-calc-y-offset)) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + (meta . ((class . Item) + (interfaces . (flag-interface font-interface)))))) (FootnoteItem . ( - (annotation-balloon . #f) - (annotation-line . #t) - (automatically-numbered . ,(grob::calc-property-by-copy 'automatically-numbered)) - (break-visibility . ,(grob::inherit-parent-property + (annotation-balloon . #f) + (annotation-line . #t) + (automatically-numbered . ,(grob::calc-property-by-copy 'automatically-numbered)) + (break-visibility . ,(grob::inherit-parent-property X 'break-visibility)) - (footnote . #t) - (footnote-text . ,(grob::calc-property-by-copy 'footnote-text)) - (stencil . ,ly:balloon-interface::print) - (text . ,(grob::calc-property-by-copy 'text)) - (X-extent . #f) - (Y-extent . #f) - (X-offset . ,(grob::calc-property-by-copy 'X-offset)) - (Y-offset . ,(grob::calc-property-by-copy 'Y-offset)) - (meta . ((class . Item) - (interfaces . (balloon-interface - footnote-interface - font-interface - text-interface)))))) + (footnote . #t) + (footnote-text . ,(grob::calc-property-by-copy 'footnote-text)) + (stencil . ,ly:balloon-interface::print) + (text . ,(grob::calc-property-by-copy 'text)) + (X-extent . #f) + (Y-extent . #f) + (X-offset . ,(grob::calc-property-by-copy 'X-offset)) + (Y-offset . ,(grob::calc-property-by-copy 'Y-offset)) + (meta . ((class . Item) + (interfaces . (balloon-interface + footnote-interface + font-interface + text-interface)))))) (FootnoteSpanner . ( - (annotation-balloon . #f) - (annotation-line . #t) - (automatically-numbered . ,(grob::calc-property-by-copy 'automatically-numbered)) - (footnote . #t) - (footnote-text . ,(grob::calc-property-by-copy 'footnote-text)) - (spanner-placement . ,LEFT) - (stencil . ,ly:balloon-interface::print-spanner) - (text . ,(grob::calc-property-by-copy 'text)) - (X-extent . #f) - (Y-extent . #f) - (X-offset . ,(grob::calc-property-by-copy 'X-offset)) - (Y-offset . ,(grob::calc-property-by-copy 'Y-offset)) - (meta . ((class . Spanner) - (interfaces . (balloon-interface + (annotation-balloon . #f) + (annotation-line . #t) + (automatically-numbered . ,(grob::calc-property-by-copy 'automatically-numbered)) + (footnote . #t) + (footnote-text . ,(grob::calc-property-by-copy 'footnote-text)) + (spanner-placement . ,LEFT) + (stencil . ,ly:balloon-interface::print-spanner) + (text . ,(grob::calc-property-by-copy 'text)) + (X-extent . #f) + (Y-extent . #f) + (X-offset . ,(grob::calc-property-by-copy 'X-offset)) + (Y-offset . ,(grob::calc-property-by-copy 'Y-offset)) + (meta . ((class . Spanner) + (interfaces . (balloon-interface footnote-interface - footnote-spanner-interface - font-interface - text-interface)))))) + footnote-spanner-interface + font-interface + text-interface)))))) (FretBoard . ( - (after-line-breaking . ,ly:chord-name::after-line-breaking) - (fret-diagram-details . ((finger-code . below-string))) - (stencil . ,fret-board::calc-stencil) - (extra-spacing-height . (0.2 . -0.2)) - (extra-spacing-width . (-0.5 . 0.5)) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (chord-name-interface - font-interface - fret-diagram-interface - rhythmic-grob-interface)))))) + (after-line-breaking . ,ly:chord-name::after-line-breaking) + (fret-diagram-details . ((finger-code . below-string))) + (stencil . ,fret-board::calc-stencil) + (extra-spacing-height . (0.2 . -0.2)) + (extra-spacing-width . (-0.5 . 0.5)) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (chord-name-interface + font-interface + fret-diagram-interface + rhythmic-grob-interface)))))) (Glissando . ( - (after-line-breaking . ,ly:spanner::kill-zero-spanned-time) - (bound-details . ((right . ((attach-dir . ,LEFT) - (end-on-accidental . #t) - (padding . 0.5) - )) - (left . ((attach-dir . ,RIGHT) - (padding . 0.5) - )) - )) - (cross-staff . ,ly:line-spanner::calc-cross-staff) - (gap . 0.5) - (left-bound-info . ,ly:line-spanner::calc-left-bound-info) - (normalized-endpoints . ,ly:spanner::calc-normalized-endpoints) - (right-bound-info . ,ly:line-spanner::calc-right-bound-info) - (simple-Y . #t) - (stencil . ,ly:line-spanner::print) - (style . line) - (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) - (X-extent . #f) - (Y-extent . #f) - (zigzag-width . 0.75) - (meta . ((class . Spanner) - (interfaces . (glissando-interface - line-interface - line-spanner-interface - unbreakable-spanner-interface)))))) + (after-line-breaking . ,ly:spanner::kill-zero-spanned-time) + (bound-details . ((right . ((attach-dir . ,LEFT) + (end-on-accidental . #t) + (padding . 0.5) + )) + (left . ((attach-dir . ,RIGHT) + (padding . 0.5) + )) + )) + (cross-staff . ,ly:line-spanner::calc-cross-staff) + (gap . 0.5) + (left-bound-info . ,ly:line-spanner::calc-left-bound-info) + (normalized-endpoints . ,ly:spanner::calc-normalized-endpoints) + (right-bound-info . ,ly:line-spanner::calc-right-bound-info) + (simple-Y . #t) + (stencil . ,ly:line-spanner::print) + (style . line) + (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) + (X-extent . #f) + (Y-extent . #f) + (zigzag-width . 0.75) + (meta . ((class . Spanner) + (interfaces . (glissando-interface + line-interface + line-spanner-interface + unbreakable-spanner-interface)))))) (GraceSpacing . ( - (common-shortest-duration . ,grace-spacing::calc-shortest-duration) - (shortest-duration-space . 1.6) - (spacing-increment . 0.8) - (meta . ((class . Spanner) - (interfaces . (grace-spacing-interface - spacing-options-interface - spanner-interface)))))) + (common-shortest-duration . ,grace-spacing::calc-shortest-duration) + (shortest-duration-space . 1.6) + (spacing-increment . 0.8) + (meta . ((class . Spanner) + (interfaces . (grace-spacing-interface + spacing-options-interface + spanner-interface)))))) (GridLine . ( - (layer . 0) - (self-alignment-X . ,CENTER) - (stencil . ,ly:grid-line-interface::print) - (X-extent . ,ly:grid-line-interface::width) - (X-offset . ,(ly:make-simple-closure - `(,+ - ,(ly:make-simple-closure - (list ly:self-alignment-interface::centered-on-x-parent)) - ,(ly:make-simple-closure - (list ly:self-alignment-interface::x-aligned-on-self))))) - (meta . ((class . Item) - (interfaces . (grid-line-interface - self-alignment-interface)))))) + (layer . 0) + (self-alignment-X . ,CENTER) + (stencil . ,ly:grid-line-interface::print) + (X-extent . ,ly:grid-line-interface::width) + (X-offset . ,(ly:make-simple-closure + `(,+ + ,(ly:make-simple-closure + (list ly:self-alignment-interface::centered-on-x-parent)) + ,(ly:make-simple-closure + (list ly:self-alignment-interface::x-aligned-on-self))))) + (meta . ((class . Item) + (interfaces . (grid-line-interface + self-alignment-interface)))))) (GridPoint . ( - (X-extent . (0 . 0)) - (Y-extent . (0 . 0)) - (meta . ((class . Item) - (interfaces . (grid-point-interface)))))) + (X-extent . (0 . 0)) + (Y-extent . (0 . 0)) + (meta . ((class . Item) + (interfaces . (grid-point-interface)))))) (Hairpin . ( - (after-line-breaking . ,ly:spanner::kill-zero-spanned-time) - (bound-padding . 1.0) - (broken-bound-padding . ,ly:hairpin::broken-bound-padding) - (circled-tip . #f) - (grow-direction . ,hairpin::calc-grow-direction) - (height . 0.6666) - (minimum-length . 2.0) - (self-alignment-Y . ,CENTER) - (springs-and-rods . ,ly:spanner::set-spacing-rods) - (stencil . ,ly:hairpin::print) - (thickness . 1.0) - (to-barline . #t) - (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) - (Y-extent . ,(grob::unpure-Y-extent-from-stencil ly:hairpin::pure-height)) - (Y-offset . ,self-alignment-interface::y-aligned-on-self) - (meta . ((class . Spanner) - (interfaces . (dynamic-interface - hairpin-interface - line-interface - self-alignment-interface - spanner-interface)))))) + (after-line-breaking . ,ly:spanner::kill-zero-spanned-time) + (bound-padding . 1.0) + (broken-bound-padding . ,ly:hairpin::broken-bound-padding) + (circled-tip . #f) + (grow-direction . ,hairpin::calc-grow-direction) + (height . 0.6666) + (minimum-length . 2.0) + (self-alignment-Y . ,CENTER) + (springs-and-rods . ,ly:spanner::set-spacing-rods) + (stencil . ,ly:hairpin::print) + (thickness . 1.0) + (to-barline . #t) + (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) + (Y-extent . ,(grob::unpure-Y-extent-from-stencil ly:hairpin::pure-height)) + (Y-offset . ,self-alignment-interface::y-aligned-on-self) + (meta . ((class . Spanner) + (interfaces . (dynamic-interface + hairpin-interface + line-interface + self-alignment-interface + spanner-interface)))))) (HorizontalBracket . ( - (bracket-flare . (0.5 . 0.5)) - (connect-to-neighbor . ,ly:tuplet-bracket::calc-connect-to-neighbors) - (direction . ,DOWN) - (padding . 0.2) - (side-axis . ,Y) - (staff-padding . 0.2) - (stencil . ,ly:horizontal-bracket::print) - (thickness . 1.0) - (Y-offset . ,side-position-interface::y-aligned-side) - (meta . ((class . Spanner) - (interfaces . (horizontal-bracket-interface - line-interface - side-position-interface - spanner-interface)))))) + (bracket-flare . (0.5 . 0.5)) + (connect-to-neighbor . ,ly:tuplet-bracket::calc-connect-to-neighbors) + (direction . ,DOWN) + (padding . 0.2) + (side-axis . ,Y) + (staff-padding . 0.2) + (stencil . ,ly:horizontal-bracket::print) + (thickness . 1.0) + (Y-offset . ,side-position-interface::y-aligned-side) + (meta . ((class . Spanner) + (interfaces . (horizontal-bracket-interface + line-interface + side-position-interface + spanner-interface)))))) (InstrumentName . ( - (direction . ,LEFT) - (padding . 0.3) - (self-alignment-X . ,CENTER) - (self-alignment-Y . ,CENTER) - (stencil . ,system-start-text::print) - (X-offset . ,system-start-text::calc-x-offset) - (Y-offset . ,system-start-text::calc-y-offset) - (meta . ((class . Spanner) - (interfaces . (font-interface - self-alignment-interface - side-position-interface - system-start-text-interface)))))) + (direction . ,LEFT) + (padding . 0.3) + (self-alignment-X . ,CENTER) + (self-alignment-Y . ,CENTER) + (stencil . ,system-start-text::print) + (X-offset . ,system-start-text::calc-x-offset) + (Y-offset . ,system-start-text::calc-y-offset) + (meta . ((class . Spanner) + (interfaces . (font-interface + self-alignment-interface + side-position-interface + system-start-text-interface)))))) (InstrumentSwitch . ( - (direction . ,UP) - (extra-spacing-width . (+inf.0 . -inf.0)) - (outside-staff-priority . 500) - (padding . 0.5) - (self-alignment-X . ,LEFT) - (side-axis . ,Y) - (staff-padding . 0.5) - (stencil . ,ly:text-interface::print) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (X-offset . ,ly:self-alignment-interface::x-aligned-on-self) - (Y-offset . ,side-position-interface::y-aligned-side) - (meta . ((class . Item) - (interfaces . (font-interface - self-alignment-interface - side-position-interface - text-interface)))))) + (direction . ,UP) + (extra-spacing-width . (+inf.0 . -inf.0)) + (outside-staff-priority . 500) + (padding . 0.5) + (self-alignment-X . ,LEFT) + (side-axis . ,Y) + (staff-padding . 0.5) + (stencil . ,ly:text-interface::print) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (X-offset . ,ly:self-alignment-interface::x-aligned-on-self) + (Y-offset . ,side-position-interface::y-aligned-side) + (meta . ((class . Item) + (interfaces . (font-interface + self-alignment-interface + side-position-interface + text-interface)))))) (KeyCancellation . ( - (break-align-symbol . key-cancellation) - (break-visibility . ,begin-of-line-invisible) - (glyph-name-alist . ,cancellation-glyph-name-alist) - (non-musical . #t) - (flat-positions . (2 3 4 2 1 2 1)) - (sharp-positions . (4 5 4 2 3 2 3)) - (space-alist . ( - (time-signature . (extra-space . 1.25)) - (staff-bar . (extra-space . 0.6)) - (key-signature . (extra-space . 0.5)) - (cue-clef . (extra-space . 0.5)) - (right-edge . (extra-space . 0.5)) - (first-note . (fixed-space . 2.5)))) - (stencil . ,ly:key-signature-interface::print) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (extra-spacing-width . (0.0 . 1.0)) - (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-including-staff) - (Y-offset . ,staff-symbol-referencer::callback) - (meta . ((class . Item) + (break-align-symbol . key-cancellation) + (break-visibility . ,begin-of-line-invisible) + (glyph-name-alist . ,cancellation-glyph-name-alist) + (non-musical . #t) + (flat-positions . (2 3 4 2 1 2 1)) + (sharp-positions . (4 5 4 2 3 2 3)) + (space-alist . ( + (time-signature . (extra-space . 1.25)) + (staff-bar . (extra-space . 0.6)) + (key-signature . (extra-space . 0.5)) + (cue-clef . (extra-space . 0.5)) + (right-edge . (extra-space . 0.5)) + (first-note . (fixed-space . 2.5)))) + (stencil . ,ly:key-signature-interface::print) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (extra-spacing-width . (0.0 . 1.0)) + (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-including-staff) + (Y-offset . ,staff-symbol-referencer::callback) + (meta . ((class . Item) (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) (pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs))) - (interfaces . (break-aligned-interface - font-interface - key-cancellation-interface - key-signature-interface - pure-from-neighbor-interface - staff-symbol-referencer-interface)))))) + (interfaces . (break-aligned-interface + font-interface + key-cancellation-interface + key-signature-interface + pure-from-neighbor-interface + staff-symbol-referencer-interface)))))) (KeySignature . ( - (avoid-slur . inside) - (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor) - (break-align-anchor-alignment . ,RIGHT) - (break-align-symbol . key-signature) - (break-visibility . ,begin-of-line-visible) - (glyph-name-alist . ,standard-alteration-glyph-name-alist) - (non-musical . #t) - (flat-positions . (2 3 4 2 1 2 1)) - (sharp-positions . (4 5 4 2 3 2 3)) - (space-alist . ( - (time-signature . (extra-space . 1.15)) - (staff-bar . (extra-space . 1.1)) - (cue-clef . (extra-space . 0.5)) - (right-edge . (extra-space . 0.5)) - (first-note . (fixed-space . 2.5)))) - (stencil . ,ly:key-signature-interface::print) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (extra-spacing-width . (0.0 . 1.0)) - (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-including-staff) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - (Y-offset . ,staff-symbol-referencer::callback) - (meta . ((class . Item) + (avoid-slur . inside) + (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor) + (break-align-anchor-alignment . ,RIGHT) + (break-align-symbol . key-signature) + (break-visibility . ,begin-of-line-visible) + (glyph-name-alist . ,standard-alteration-glyph-name-alist) + (non-musical . #t) + (flat-positions . (2 3 4 2 1 2 1)) + (sharp-positions . (4 5 4 2 3 2 3)) + (space-alist . ( + (time-signature . (extra-space . 1.15)) + (staff-bar . (extra-space . 1.1)) + (cue-clef . (extra-space . 0.5)) + (right-edge . (extra-space . 0.5)) + (first-note . (fixed-space . 2.5)))) + (stencil . ,ly:key-signature-interface::print) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (extra-spacing-width . (0.0 . 1.0)) + (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-including-staff) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + (Y-offset . ,staff-symbol-referencer::callback) + (meta . ((class . Item) (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) (pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs))) - (interfaces . (break-aligned-interface - font-interface - key-signature-interface - pure-from-neighbor-interface - staff-symbol-referencer-interface)))))) + (interfaces . (break-aligned-interface + font-interface + key-signature-interface + pure-from-neighbor-interface + staff-symbol-referencer-interface)))))) (KievanLigature . ( - (springs-and-rods . ,ly:spanner::set-spacing-rods) - (stencil . ,ly:kievan-ligature::print) - (padding . 0.5) - (meta . ((class . Spanner) - (interfaces . (font-interface - kievan-ligature-interface)))))) - - (LaissezVibrerTie - . ( - (control-points . ,ly:semi-tie::calc-control-points) - (cross-staff . ,semi-tie::calc-cross-staff) - (details . ((ratio . 0.333) - (height-limit . 1.0))) - (direction . ,ly:tie::calc-direction) - (head-direction . ,LEFT) - (stencil . ,laissez-vibrer::print) - (thickness . 1.0) - (extra-spacing-height . (-0.5 . 0.5)) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (semi-tie-interface)))))) + (springs-and-rods . ,ly:spanner::set-spacing-rods) + (stencil . ,ly:kievan-ligature::print) + (padding . 0.5) + (meta . ((class . Spanner) + (interfaces . (font-interface + kievan-ligature-interface)))))) + + (LaissezVibrerTie + . ( + (control-points . ,ly:semi-tie::calc-control-points) + (cross-staff . ,semi-tie::calc-cross-staff) + (details . ((ratio . 0.333) + (height-limit . 1.0))) + (direction . ,ly:tie::calc-direction) + (head-direction . ,LEFT) + (stencil . ,laissez-vibrer::print) + (thickness . 1.0) + (extra-spacing-height . (-0.5 . 0.5)) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (semi-tie-interface)))))) (LaissezVibrerTieColumn . ( - (head-direction . ,ly:semi-tie-column::calc-head-direction) - (positioning-done . ,ly:semi-tie-column::calc-positioning-done) - (X-extent . #f) - (Y-extent . #f) - (meta . ((class . Item) - (interfaces . (semi-tie-column-interface)))))) + (head-direction . ,ly:semi-tie-column::calc-head-direction) + (positioning-done . ,ly:semi-tie-column::calc-positioning-done) + (X-extent . #f) + (Y-extent . #f) + (meta . ((class . Item) + (interfaces . (semi-tie-column-interface)))))) (LedgerLineSpanner . ( - (layer . 0) - (length-fraction . 0.25) - (minimum-length-fraction . 0.25) - (springs-and-rods . ,ly:ledger-line-spanner::set-spacing-rods) - (stencil . ,ly:ledger-line-spanner::print) - (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) - (X-extent . #f) - (Y-extent . #f) - (meta . ((class . Spanner) - (interfaces . (ledger-line-spanner-interface)))))) + (layer . 0) + (length-fraction . 0.25) + (minimum-length-fraction . 0.25) + (springs-and-rods . ,ly:ledger-line-spanner::set-spacing-rods) + (stencil . ,ly:ledger-line-spanner::print) + (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) + (X-extent . #f) + (Y-extent . #f) + (meta . ((class . Spanner) + (interfaces . (ledger-line-spanner-interface)))))) (LeftEdge . ( - (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor) - (break-align-symbol . left-edge) - (break-visibility . ,center-invisible) - (non-musical . #t) - (extra-spacing-height . (+inf.0 . -inf.0)) - (space-alist . ( - (ambitus . (extra-space . 2.0)) - (breathing-sign . (minimum-space . 0.0)) - (cue-end-clef . (extra-space . 0.8)) - (clef . (extra-space . 0.8)) - (cue-clef . (extra-space . 0.8)) - (staff-bar . (extra-space . 0.0)) - (key-cancellation . (extra-space . 0.0)) - (key-signature . (extra-space . 0.8)) - (time-signature . (extra-space . 1.0)) - (custos . (extra-space . 0.0)) - (first-note . (fixed-space . 2.0)) - (right-edge . (extra-space . 0.0)) - )) - (X-extent . (0 . 0)) - (meta . ((class . Item) - (interfaces . (break-aligned-interface)))))) + (break-align-anchor . ,ly:break-aligned-interface::calc-extent-aligned-anchor) + (break-align-symbol . left-edge) + (break-visibility . ,center-invisible) + (non-musical . #t) + (extra-spacing-height . (+inf.0 . -inf.0)) + (space-alist . ( + (ambitus . (extra-space . 2.0)) + (breathing-sign . (minimum-space . 0.0)) + (cue-end-clef . (extra-space . 0.8)) + (clef . (extra-space . 0.8)) + (cue-clef . (extra-space . 0.8)) + (staff-bar . (extra-space . 0.0)) + (key-cancellation . (extra-space . 0.0)) + (key-signature . (extra-space . 0.8)) + (time-signature . (extra-space . 1.0)) + (custos . (extra-space . 0.0)) + (first-note . (fixed-space . 2.0)) + (right-edge . (extra-space . 0.0)) + )) + (X-extent . (0 . 0)) + (meta . ((class . Item) + (interfaces . (break-aligned-interface)))))) (LigatureBracket . ( - ;; ugh. A ligature bracket is totally different from - ;; a tuplet bracket. - - (bracket-visibility . #t) - (connect-to-neighbor . ,ly:tuplet-bracket::calc-connect-to-neighbors) - (direction . ,UP) - (edge-height . (0.7 . 0.7)) - (padding . 2.0) - (positions . ,ly:tuplet-bracket::calc-positions) - (shorten-pair . (-0.2 . -0.2)) - (staff-padding . 0.25) - (stencil . ,ly:tuplet-bracket::print) - (thickness . 1.6) - (X-positions . ,ly:tuplet-bracket::calc-x-positions) - (meta . ((class . Spanner) - (interfaces . (line-interface - tuplet-bracket-interface)))))) + ;; ugh. A ligature bracket is totally different from + ;; a tuplet bracket. + + (bracket-visibility . #t) + (connect-to-neighbor . ,ly:tuplet-bracket::calc-connect-to-neighbors) + (direction . ,UP) + (edge-height . (0.7 . 0.7)) + (padding . 2.0) + (positions . ,ly:tuplet-bracket::calc-positions) + (shorten-pair . (-0.2 . -0.2)) + (staff-padding . 0.25) + (stencil . ,ly:tuplet-bracket::print) + (thickness . 1.6) + (X-positions . ,ly:tuplet-bracket::calc-x-positions) + (meta . ((class . Spanner) + (interfaces . (line-interface + tuplet-bracket-interface)))))) (LyricExtender . ( - (minimum-length . 1.5) - (stencil . ,ly:lyric-extender::print) - (thickness . 0.8) ; line-thickness - (Y-extent . (0 . 0)) - (meta . ((class . Spanner) - (interfaces . (lyric-extender-interface - lyric-interface)))))) + (minimum-length . 1.5) + (stencil . ,ly:lyric-extender::print) + (thickness . 0.8) ; line-thickness + (Y-extent . (0 . 0)) + (meta . ((class . Spanner) + (interfaces . (lyric-extender-interface + lyric-interface)))))) (LyricHyphen . ( - (after-line-breaking . ,ly:spanner::kill-zero-spanned-time) - (dash-period . 10.0) - (height . 0.42) - (length . 0.66) - (minimum-distance . 0.1) - (minimum-length . 0.3) - (padding . 0.07) - (springs-and-rods . ,ly:lyric-hyphen::set-spacing-rods) - (stencil . ,ly:lyric-hyphen::print) - (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) - (thickness . 1.3) - (Y-extent . (0 . 0)) - (meta . ((class . Spanner) - (interfaces . (font-interface - lyric-hyphen-interface - lyric-interface - spanner-interface)))))) + (after-line-breaking . ,ly:spanner::kill-zero-spanned-time) + (dash-period . 10.0) + (height . 0.42) + (length . 0.66) + (minimum-distance . 0.1) + (minimum-length . 0.3) + (padding . 0.07) + (springs-and-rods . ,ly:lyric-hyphen::set-spacing-rods) + (stencil . ,ly:lyric-hyphen::print) + (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) + (thickness . 1.3) + (Y-extent . (0 . 0)) + (meta . ((class . Spanner) + (interfaces . (font-interface + lyric-hyphen-interface + lyric-interface + spanner-interface)))))) (LyricSpace . ( - (minimum-distance . 0.45) - (padding . 0.0) - (springs-and-rods . ,ly:lyric-hyphen::set-spacing-rods) - (X-extent . #f) - (Y-extent . #f) - (meta . ((class . Spanner) - (interfaces . (lyric-hyphen-interface - spanner-interface)))))) + (minimum-distance . 0.45) + (padding . 0.0) + (springs-and-rods . ,ly:lyric-hyphen::set-spacing-rods) + (X-extent . #f) + (Y-extent . #f) + (meta . ((class . Spanner) + (interfaces . (lyric-hyphen-interface + spanner-interface)))))) (LyricText . ( - (extra-spacing-width . (0.0 . 0.0)) - ;; Recede in height for purposes of note spacing, - ;; so notes in melismata can be freely spaced above lyrics - (extra-spacing-height . (0.2 . -0.2)) - (font-series . medium) - (font-size . 1.0) - (self-alignment-X . ,CENTER) - (stencil . ,lyric-text::print) - (text . ,(grob::calc-property-by-copy 'text)) - (word-space . 0.6) - (skyline-horizontal-padding . 0.1) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - (X-offset . ,ly:self-alignment-interface::aligned-on-x-parent) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (font-interface - lyric-syllable-interface - rhythmic-grob-interface - self-alignment-interface - text-interface)))))) + (extra-spacing-width . (0.0 . 0.0)) + ;; Recede in height for purposes of note spacing, + ;; so notes in melismata can be freely spaced above lyrics + (extra-spacing-height . (0.2 . -0.2)) + (font-series . medium) + (font-size . 1.0) + (self-alignment-X . ,CENTER) + (stencil . ,lyric-text::print) + (text . ,(grob::calc-property-by-copy 'text)) + (word-space . 0.6) + (skyline-horizontal-padding . 0.1) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + (X-offset . ,ly:self-alignment-interface::aligned-on-x-parent) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (font-interface + lyric-syllable-interface + rhythmic-grob-interface + self-alignment-interface + text-interface)))))) (MeasureCounter . ( @@ -1411,1347 +1411,1347 @@ (outside-staff-padding . 0.5) (outside-staff-priority . 750) (self-alignment-X . ,CENTER) - (side-axis . ,Y) + (side-axis . ,Y) (staff-padding . 0.5) (stencil . ,measure-counter-stencil) (meta . ((class . Spanner) (interfaces . (font-interface measure-counter-interface self-alignment-interface - side-position-interface + side-position-interface text-interface)))))) (MeasureGrouping . ( - (direction . ,UP) - (height . 2.0) - (padding . 2) - (side-axis . ,Y) - (staff-padding . 3) - (stencil . ,ly:measure-grouping::print) - (thickness . 1) - (Y-offset . ,side-position-interface::y-aligned-side) - (meta . ((class . Spanner) - (interfaces . (measure-grouping-interface - side-position-interface)))))) + (direction . ,UP) + (height . 2.0) + (padding . 2) + (side-axis . ,Y) + (staff-padding . 3) + (stencil . ,ly:measure-grouping::print) + (thickness . 1) + (Y-offset . ,side-position-interface::y-aligned-side) + (meta . ((class . Spanner) + (interfaces . (measure-grouping-interface + side-position-interface)))))) (MelodyItem . ( - (neutral-direction . ,DOWN) - (meta . ((class . Item) - (interfaces . (melody-spanner-interface)))))) + (neutral-direction . ,DOWN) + (meta . ((class . Item) + (interfaces . (melody-spanner-interface)))))) (MensuralLigature . ( - (springs-and-rods . ,ly:spanner::set-spacing-rods) - (stencil . ,ly:mensural-ligature::print) - (thickness . 1.3) - (meta . ((class . Spanner) - (interfaces . (font-interface - mensural-ligature-interface)))))) + (springs-and-rods . ,ly:spanner::set-spacing-rods) + (stencil . ,ly:mensural-ligature::print) + (thickness . 1.3) + (meta . ((class . Spanner) + (interfaces . (font-interface + mensural-ligature-interface)))))) (MetronomeMark . ( - (after-line-breaking . ,ly:side-position-interface::move-to-extremal-staff) - (break-visibility . ,end-of-line-invisible) - (direction . ,UP) - (extra-spacing-width . (+inf.0 . -inf.0)) - (outside-staff-horizontal-padding . 0.2) - (outside-staff-priority . 1000) - (padding . 0.8) - (side-axis . ,Y) - (stencil . ,ly:text-interface::print) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - (Y-offset . ,side-position-interface::y-aligned-side) - (X-offset . ,(ly:make-simple-closure - `(,+ - ,(ly:make-simple-closure - (list ly:break-alignable-interface::self-align-callback)) - ,(ly:make-simple-closure - (list ly:self-alignment-interface::x-aligned-on-self))))) - (self-alignment-X . ,LEFT) - (break-align-symbols . (time-signature)) - (non-break-align-symbols . (paper-column-interface)) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (break-alignable-interface - font-interface - metronome-mark-interface - self-alignment-interface - side-position-interface - text-interface)))))) + (after-line-breaking . ,ly:side-position-interface::move-to-extremal-staff) + (break-visibility . ,end-of-line-invisible) + (direction . ,UP) + (extra-spacing-width . (+inf.0 . -inf.0)) + (outside-staff-horizontal-padding . 0.2) + (outside-staff-priority . 1000) + (padding . 0.8) + (side-axis . ,Y) + (stencil . ,ly:text-interface::print) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + (Y-offset . ,side-position-interface::y-aligned-side) + (X-offset . ,(ly:make-simple-closure + `(,+ + ,(ly:make-simple-closure + (list ly:break-alignable-interface::self-align-callback)) + ,(ly:make-simple-closure + (list ly:self-alignment-interface::x-aligned-on-self))))) + (self-alignment-X . ,LEFT) + (break-align-symbols . (time-signature)) + (non-break-align-symbols . (paper-column-interface)) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (break-alignable-interface + font-interface + metronome-mark-interface + self-alignment-interface + side-position-interface + text-interface)))))) (MultiMeasureRest . ( - (expand-limit . 10) - (hair-thickness . 2.0) - (round-up-exceptions . ()) - (padding . 1) - (spacing-pair . (break-alignment . break-alignment)) - (springs-and-rods . ,ly:multi-measure-rest::set-spacing-rods) - (stencil . ,ly:multi-measure-rest::print) - (thick-thickness . 6.6) - ;; See Wanske pp. 125 - (usable-duration-logs . ,(iota 4 -3)) - (Y-extent . ,(ly:make-unpure-pure-container ly:multi-measure-rest::height)) - (Y-offset . ,staff-symbol-referencer::callback) - (meta . ((class . Spanner) - (interfaces . (font-interface - multi-measure-interface - multi-measure-rest-interface - rest-interface - staff-symbol-referencer-interface)))))) + (expand-limit . 10) + (hair-thickness . 2.0) + (round-up-exceptions . ()) + (padding . 1) + (spacing-pair . (break-alignment . break-alignment)) + (springs-and-rods . ,ly:multi-measure-rest::set-spacing-rods) + (stencil . ,ly:multi-measure-rest::print) + (thick-thickness . 6.6) + ;; See Wanske pp. 125 + (usable-duration-logs . ,(iota 4 -3)) + (Y-extent . ,(ly:make-unpure-pure-container ly:multi-measure-rest::height)) + (Y-offset . ,staff-symbol-referencer::callback) + (meta . ((class . Spanner) + (interfaces . (font-interface + multi-measure-interface + multi-measure-rest-interface + rest-interface + staff-symbol-referencer-interface)))))) (MultiMeasureRestNumber . ( - (bound-padding . 2.0) - (direction . ,UP) - (font-encoding . fetaText) - (padding . 0.4) - (self-alignment-X . ,CENTER) - (side-axis . ,Y) - (springs-and-rods . ,ly:multi-measure-rest::set-text-rods) - (staff-padding . 0.4) - (stencil . ,ly:text-interface::print) - (X-offset . ,(ly:make-simple-closure - `(,+ - ,(ly:make-simple-closure - (list ly:self-alignment-interface::x-aligned-on-self)) - ,(ly:make-simple-closure - (list ly:self-alignment-interface::x-centered-on-y-parent))))) - (Y-offset . ,side-position-interface::y-aligned-side) - (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Spanner) - (interfaces . (font-interface - multi-measure-interface - self-alignment-interface - side-position-interface - text-interface)))))) + (bound-padding . 2.0) + (direction . ,UP) + (font-encoding . fetaText) + (padding . 0.4) + (self-alignment-X . ,CENTER) + (side-axis . ,Y) + (springs-and-rods . ,ly:multi-measure-rest::set-text-rods) + (staff-padding . 0.4) + (stencil . ,ly:text-interface::print) + (X-offset . ,(ly:make-simple-closure + `(,+ + ,(ly:make-simple-closure + (list ly:self-alignment-interface::x-aligned-on-self)) + ,(ly:make-simple-closure + (list ly:self-alignment-interface::x-centered-on-y-parent))))) + (Y-offset . ,side-position-interface::y-aligned-side) + (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Spanner) + (interfaces . (font-interface + multi-measure-interface + self-alignment-interface + side-position-interface + text-interface)))))) (MultiMeasureRestText . ( - (direction . ,UP) - (outside-staff-priority . 450) - (padding . 0.2) - (self-alignment-X . ,CENTER) - (skyline-horizontal-padding . 0.2) - (staff-padding . 0.25) - (stencil . ,ly:text-interface::print) - (X-offset . ,(ly:make-simple-closure - `(,+ - ,(ly:make-simple-closure - (list ly:self-alignment-interface::x-centered-on-y-parent)) - ,(ly:make-simple-closure - (list ly:self-alignment-interface::x-aligned-on-self))))) - (Y-offset . ,side-position-interface::y-aligned-side) - (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Spanner) - (interfaces . (font-interface - multi-measure-interface - self-alignment-interface - side-position-interface - text-interface)))))) + (direction . ,UP) + (outside-staff-priority . 450) + (padding . 0.2) + (self-alignment-X . ,CENTER) + (skyline-horizontal-padding . 0.2) + (staff-padding . 0.25) + (stencil . ,ly:text-interface::print) + (X-offset . ,(ly:make-simple-closure + `(,+ + ,(ly:make-simple-closure + (list ly:self-alignment-interface::x-centered-on-y-parent)) + ,(ly:make-simple-closure + (list ly:self-alignment-interface::x-aligned-on-self))))) + (Y-offset . ,side-position-interface::y-aligned-side) + (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Spanner) + (interfaces . (font-interface + multi-measure-interface + self-alignment-interface + side-position-interface + text-interface)))))) (NonMusicalPaperColumn . ( - (allow-loose-spacing . #t) - (axes . (,X)) - (before-line-breaking . ,ly:paper-column::before-line-breaking) - (bound-alignment-interfaces . (break-alignment-interface)) - (full-measure-extra-space . 1.0) - (horizontal-skylines . ,ly:separation-item::calc-skylines) - ;; (stencil . ,ly:paper-column::print) - - (keep-inside-line . #t) - (line-break-permission . allow) - (non-musical . #t) - (page-break-permission . allow) - - ;; debugging stuff: print column number. - ;; (font-size . -6) (font-name . "sans") (Y-extent . #f) - - (X-extent . ,ly:axis-group-interface::width) - (meta . ((class . Paper_column) - (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) - (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) - (interfaces . (axis-group-interface - font-interface - paper-column-interface - separation-item-interface - spaceable-grob-interface)))))) + (allow-loose-spacing . #t) + (axes . (,X)) + (before-line-breaking . ,ly:paper-column::before-line-breaking) + (bound-alignment-interfaces . (break-alignment-interface)) + (full-measure-extra-space . 1.0) + (horizontal-skylines . ,ly:separation-item::calc-skylines) + ;; (stencil . ,ly:paper-column::print) + + (keep-inside-line . #t) + (line-break-permission . allow) + (non-musical . #t) + (page-break-permission . allow) + + ;; debugging stuff: print column number. + ;; (font-size . -6) (font-name . "sans") (Y-extent . #f) + + (X-extent . ,ly:axis-group-interface::width) + (meta . ((class . Paper_column) + (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) + (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) + (interfaces . (axis-group-interface + font-interface + paper-column-interface + separation-item-interface + spaceable-grob-interface)))))) (NoteCollision . ( - (axes . (,X ,Y)) - (positioning-done . ,ly:note-collision-interface::calc-positioning-done) - (prefer-dotted-right . #t) - (X-extent . ,ly:axis-group-interface::width) - (Y-extent . ,axis-group-interface::height) - (meta . ((class . Item) - (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) - (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) - (interfaces . (axis-group-interface - note-collision-interface)))))) + (axes . (,X ,Y)) + (positioning-done . ,ly:note-collision-interface::calc-positioning-done) + (prefer-dotted-right . #t) + (X-extent . ,ly:axis-group-interface::width) + (Y-extent . ,axis-group-interface::height) + (meta . ((class . Item) + (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) + (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) + (interfaces . (axis-group-interface + note-collision-interface)))))) (NoteColumn . ( - (axes . (,X ,Y)) - (bound-alignment-interfaces . (rhythmic-head-interface stem-interface)) - (cross-staff . ,ly:axis-group-interface::cross-staff) - (horizontal-skylines . ,ly:separation-item::calc-skylines) - (skyline-vertical-padding . 0.15) - (X-extent . ,ly:axis-group-interface::width) - (Y-extent . ,axis-group-interface::height) - (meta . ((class . Item) - (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) - (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) - (interfaces . (axis-group-interface - note-column-interface - separation-item-interface)))))) + (axes . (,X ,Y)) + (bound-alignment-interfaces . (rhythmic-head-interface stem-interface)) + (cross-staff . ,ly:axis-group-interface::cross-staff) + (horizontal-skylines . ,ly:separation-item::calc-skylines) + (skyline-vertical-padding . 0.15) + (X-extent . ,ly:axis-group-interface::width) + (Y-extent . ,axis-group-interface::height) + (meta . ((class . Item) + (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) + (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) + (interfaces . (axis-group-interface + note-column-interface + separation-item-interface)))))) (NoteHead . ( - (flexa-width . 2.0) - (duration-log . ,note-head::calc-duration-log) - (extra-spacing-height . ,ly:note-head::include-ledger-line-height) - (glyph-name . ,note-head::calc-glyph-name) - (ligature-flexa . #f) - (stem-attachment . ,ly:note-head::calc-stem-attachment) - (stencil . ,ly:note-head::print) - (X-offset . ,ly:note-head::stem-x-shift) - (Y-offset . ,staff-symbol-referencer::callback) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (font-interface - gregorian-ligature-interface - ledgered-interface + (flexa-width . 2.0) + (duration-log . ,note-head::calc-duration-log) + (extra-spacing-height . ,ly:note-head::include-ledger-line-height) + (glyph-name . ,note-head::calc-glyph-name) + (ligature-flexa . #f) + (stem-attachment . ,ly:note-head::calc-stem-attachment) + (stencil . ,ly:note-head::print) + (X-offset . ,ly:note-head::stem-x-shift) + (Y-offset . ,staff-symbol-referencer::callback) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (font-interface + gregorian-ligature-interface + ledgered-interface ligature-head-interface - mensural-ligature-interface - note-head-interface - rhythmic-grob-interface - rhythmic-head-interface - staff-symbol-referencer-interface - vaticana-ligature-interface)))))) + mensural-ligature-interface + note-head-interface + rhythmic-grob-interface + rhythmic-head-interface + staff-symbol-referencer-interface + vaticana-ligature-interface)))))) (NoteName . ( - (stencil . ,ly:text-interface::print) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (font-interface - note-name-interface - text-interface)))))) + (stencil . ,ly:text-interface::print) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (font-interface + note-name-interface + text-interface)))))) (NoteSpacing . ( - ;; Changed this from 0.75. - ;; If you ever change this back, please document! --hwn - (knee-spacing-correction . 1.0) - (same-direction-correction . 0.25) - (space-to-barline . #t) - (stem-spacing-correction . 0.5) - (meta . ((class . Item) - (interfaces . (note-spacing-interface - spacing-interface)))))) + ;; Changed this from 0.75. + ;; If you ever change this back, please document! --hwn + (knee-spacing-correction . 1.0) + (same-direction-correction . 0.25) + (space-to-barline . #t) + (stem-spacing-correction . 0.5) + (meta . ((class . Item) + (interfaces . (note-spacing-interface + spacing-interface)))))) (OttavaBracket . ( - (dash-fraction . 0.3) - (direction . ,UP) - (edge-height . (0 . 1.2)) - (font-shape . italic) - (minimum-length . 1.0) - (outside-staff-priority . 400) - (padding . 0.5) - (shorten-pair . (0.0 . -0.6)) - (staff-padding . 1.0) - (stencil . ,ly:ottava-bracket::print) - (style . dashed-line) - (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) - (Y-offset . ,side-position-interface::y-aligned-side) - (meta . ((class . Spanner) - (interfaces . (font-interface - horizontal-bracket-interface - line-interface - ottava-bracket-interface - side-position-interface - text-interface)))))) + (dash-fraction . 0.3) + (direction . ,UP) + (edge-height . (0 . 1.2)) + (font-shape . italic) + (minimum-length . 1.0) + (outside-staff-priority . 400) + (padding . 0.5) + (shorten-pair . (0.0 . -0.6)) + (staff-padding . 1.0) + (stencil . ,ly:ottava-bracket::print) + (style . dashed-line) + (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) + (Y-offset . ,side-position-interface::y-aligned-side) + (meta . ((class . Spanner) + (interfaces . (font-interface + horizontal-bracket-interface + line-interface + ottava-bracket-interface + side-position-interface + text-interface)))))) (PaperColumn . ( - (allow-loose-spacing . #t) - (axes . (,X)) - (before-line-breaking . ,ly:paper-column::before-line-breaking) - (bound-alignment-interfaces . (note-column-interface)) - (horizontal-skylines . ,ly:separation-item::calc-skylines) - (keep-inside-line . #t) - ; 0.08 comes from spacing-horizontal-skyline.ly - ; allows double flat of F to be nestled over dots of C - (skyline-vertical-padding . 0.08) - ;; (stencil . ,ly:paper-column::print) - (X-extent . ,ly:axis-group-interface::width) - - ;; debugging - ;; (font-size . -6) (font-name . "sans") (Y-extent . #f) - (meta . ((class . Paper_column) - (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) - (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) - (interfaces . (axis-group-interface - font-interface - paper-column-interface - separation-item-interface - spaceable-grob-interface)))))) + (allow-loose-spacing . #t) + (axes . (,X)) + (before-line-breaking . ,ly:paper-column::before-line-breaking) + (bound-alignment-interfaces . (note-column-interface)) + (horizontal-skylines . ,ly:separation-item::calc-skylines) + (keep-inside-line . #t) + ; 0.08 comes from spacing-horizontal-skyline.ly + ; allows double flat of F to be nestled over dots of C + (skyline-vertical-padding . 0.08) + ;; (stencil . ,ly:paper-column::print) + (X-extent . ,ly:axis-group-interface::width) + + ;; debugging + ;; (font-size . -6) (font-name . "sans") (Y-extent . #f) + (meta . ((class . Paper_column) + (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) + (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) + (interfaces . (axis-group-interface + font-interface + paper-column-interface + separation-item-interface + spaceable-grob-interface)))))) (ParenthesesItem . ( - (font-size . -6) - (padding . 0.2) - (stencil . ,parentheses-item::print) - (stencils . ,parentheses-item::calc-parenthesis-stencils) - (meta . ((class . Item) - (interfaces . (font-interface - parentheses-interface)))))) + (font-size . -6) + (padding . 0.2) + (stencil . ,parentheses-item::print) + (stencils . ,parentheses-item::calc-parenthesis-stencils) + (meta . ((class . Item) + (interfaces . (font-interface + parentheses-interface)))))) (PercentRepeat . ( - (dot-negative-kern . 0.75) - (font-encoding . fetaMusic) - (slope . 1.0) - (spacing-pair . (break-alignment . staff-bar)) - (springs-and-rods . ,ly:multi-measure-rest::set-spacing-rods) - (stencil . ,ly:multi-measure-rest::percent) - (thickness . 0.48) - (meta . ((class . Spanner) - (interfaces . (font-interface - multi-measure-rest-interface - percent-repeat-interface)))))) + (dot-negative-kern . 0.75) + (font-encoding . fetaMusic) + (slope . 1.0) + (spacing-pair . (break-alignment . staff-bar)) + (springs-and-rods . ,ly:multi-measure-rest::set-spacing-rods) + (stencil . ,ly:multi-measure-rest::percent) + (thickness . 0.48) + (meta . ((class . Spanner) + (interfaces . (font-interface + multi-measure-rest-interface + percent-repeat-interface)))))) (PercentRepeatCounter . ( - (direction . ,UP) - (font-encoding . fetaText) - (font-size . -2) - (padding . 0.2) - (self-alignment-X . ,CENTER) - (staff-padding . 0.25) - (stencil . ,ly:text-interface::print) - (X-offset . ,(ly:make-simple-closure - `(,+ - ,(ly:make-simple-closure - (list ly:self-alignment-interface::x-centered-on-y-parent)) - ,(ly:make-simple-closure - (list ly:self-alignment-interface::x-aligned-on-self))))) - (Y-offset . ,side-position-interface::y-aligned-side) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Spanner) - (interfaces . (font-interface - percent-repeat-interface - self-alignment-interface - side-position-interface - text-interface)))))) + (direction . ,UP) + (font-encoding . fetaText) + (font-size . -2) + (padding . 0.2) + (self-alignment-X . ,CENTER) + (staff-padding . 0.25) + (stencil . ,ly:text-interface::print) + (X-offset . ,(ly:make-simple-closure + `(,+ + ,(ly:make-simple-closure + (list ly:self-alignment-interface::x-centered-on-y-parent)) + ,(ly:make-simple-closure + (list ly:self-alignment-interface::x-aligned-on-self))))) + (Y-offset . ,side-position-interface::y-aligned-side) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Spanner) + (interfaces . (font-interface + percent-repeat-interface + self-alignment-interface + side-position-interface + text-interface)))))) (PhrasingSlur . ( - (control-points . ,ly:slur::calc-control-points) - (cross-staff . ,ly:slur::calc-cross-staff) - (details . ,default-slur-details) - (direction . ,ly:slur::calc-direction) - (height-limit . 2.0) - (minimum-length . 1.5) - (ratio . 0.333) - (spanner-id . "") - (springs-and-rods . ,ly:spanner::set-spacing-rods) - (stencil . ,ly:slur::print) - (thickness . 1.1) - (vertical-skylines . ,(ly:make-unpure-pure-container ly:slur::vertical-skylines ly:grob::pure-simple-vertical-skylines-from-extents)) - (Y-extent . ,slur::height) - (meta . ((class . Spanner) - (interfaces . (slur-interface)))))) + (control-points . ,ly:slur::calc-control-points) + (cross-staff . ,ly:slur::calc-cross-staff) + (details . ,default-slur-details) + (direction . ,ly:slur::calc-direction) + (height-limit . 2.0) + (minimum-length . 1.5) + (ratio . 0.333) + (spanner-id . "") + (springs-and-rods . ,ly:spanner::set-spacing-rods) + (stencil . ,ly:slur::print) + (thickness . 1.1) + (vertical-skylines . ,(ly:make-unpure-pure-container ly:slur::vertical-skylines ly:grob::pure-simple-vertical-skylines-from-extents)) + (Y-extent . ,slur::height) + (meta . ((class . Spanner) + (interfaces . (slur-interface)))))) ;; an example of a text spanner (PianoPedalBracket . ( - (bound-padding . 1.0) - (bracket-flare . (0.5 . 0.5)) - (direction . ,DOWN) - (edge-height . (1.0 . 1.0)) - (shorten-pair . (0.0 . 0.0)) - (stencil . ,ly:piano-pedal-bracket::print) - (style . line) - (thickness . 1.0) - (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) - (meta . ((class . Spanner) - (interfaces . (line-interface - piano-pedal-bracket-interface - piano-pedal-interface)))))) + (bound-padding . 1.0) + (bracket-flare . (0.5 . 0.5)) + (direction . ,DOWN) + (edge-height . (1.0 . 1.0)) + (shorten-pair . (0.0 . 0.0)) + (stencil . ,ly:piano-pedal-bracket::print) + (style . line) + (thickness . 1.0) + (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) + (meta . ((class . Spanner) + (interfaces . (line-interface + piano-pedal-bracket-interface + piano-pedal-interface)))))) (RehearsalMark . ( - (after-line-breaking . ,ly:side-position-interface::move-to-extremal-staff) - (baseline-skip . 2) - (break-align-symbols . (staff-bar key-signature clef)) - (break-visibility . ,end-of-line-invisible) - (direction . ,UP) - (extra-spacing-width . (+inf.0 . -inf.0)) - (font-size . 2) - (non-musical . #t) - (outside-staff-horizontal-padding . 0.12) - (outside-staff-priority . 1500) - (padding . 0.8) - (self-alignment-X . ,CENTER) - (stencil . ,ly:text-interface::print) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - (X-offset . ,(ly:make-simple-closure - `(,+ - ,(ly:make-simple-closure - (list ly:break-alignable-interface::self-align-callback)) - ,(ly:make-simple-closure - (list ly:self-alignment-interface::x-aligned-on-self))))) - (Y-offset . ,side-position-interface::y-aligned-side) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (break-alignable-interface - font-interface - mark-interface - self-alignment-interface - side-position-interface - text-interface)))))) + (after-line-breaking . ,ly:side-position-interface::move-to-extremal-staff) + (baseline-skip . 2) + (break-align-symbols . (staff-bar key-signature clef)) + (break-visibility . ,end-of-line-invisible) + (direction . ,UP) + (extra-spacing-width . (+inf.0 . -inf.0)) + (font-size . 2) + (non-musical . #t) + (outside-staff-horizontal-padding . 0.12) + (outside-staff-priority . 1500) + (padding . 0.8) + (self-alignment-X . ,CENTER) + (stencil . ,ly:text-interface::print) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + (X-offset . ,(ly:make-simple-closure + `(,+ + ,(ly:make-simple-closure + (list ly:break-alignable-interface::self-align-callback)) + ,(ly:make-simple-closure + (list ly:self-alignment-interface::x-aligned-on-self))))) + (Y-offset . ,side-position-interface::y-aligned-side) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (break-alignable-interface + font-interface + mark-interface + self-alignment-interface + side-position-interface + text-interface)))))) (RepeatSlash . ( - (slash-negative-kern . 0.85) - (slope . 1.7) - (stencil . ,ly:percent-repeat-item-interface::beat-slash) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (thickness . 0.48) - (meta . ((class . Item) - (interfaces . (percent-repeat-interface - percent-repeat-item-interface - rhythmic-grob-interface)))))) + (slash-negative-kern . 0.85) + (slope . 1.7) + (stencil . ,ly:percent-repeat-item-interface::beat-slash) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (thickness . 0.48) + (meta . ((class . Item) + (interfaces . (percent-repeat-interface + percent-repeat-item-interface + rhythmic-grob-interface)))))) (RepeatTie . ( - (cross-staff . ,semi-tie::calc-cross-staff) - (control-points . ,ly:semi-tie::calc-control-points) - (details . ((ratio . 0.333) - (height-limit . 1.0))) - (direction . ,ly:tie::calc-direction) - (head-direction . ,RIGHT) - (stencil . ,ly:tie::print) - (thickness . 1.0) - (extra-spacing-height . (-0.5 . 0.5)) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - (meta . ((class . Item) - (interfaces . (semi-tie-interface)))))) + (cross-staff . ,semi-tie::calc-cross-staff) + (control-points . ,ly:semi-tie::calc-control-points) + (details . ((ratio . 0.333) + (height-limit . 1.0))) + (direction . ,ly:tie::calc-direction) + (head-direction . ,RIGHT) + (stencil . ,ly:tie::print) + (thickness . 1.0) + (extra-spacing-height . (-0.5 . 0.5)) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + (meta . ((class . Item) + (interfaces . (semi-tie-interface)))))) (RepeatTieColumn . ( - (direction . ,ly:tie::calc-direction) - (head-direction . ,ly:semi-tie-column::calc-head-direction) - (positioning-done . ,ly:semi-tie-column::calc-positioning-done) - (X-extent . #f) - (Y-extent . #f) - (meta . ((class . Item) - (interfaces . (semi-tie-column-interface)))))) + (direction . ,ly:tie::calc-direction) + (head-direction . ,ly:semi-tie-column::calc-head-direction) + (positioning-done . ,ly:semi-tie-column::calc-positioning-done) + (X-extent . #f) + (Y-extent . #f) + (meta . ((class . Item) + (interfaces . (semi-tie-column-interface)))))) (Rest . ( - (cross-staff . ,ly:rest::calc-cross-staff) - (duration-log . ,stem::calc-duration-log) - (minimum-distance . 0.25) - (stencil . ,ly:rest::print) - (X-extent . ,ly:rest::width) - (Y-extent . ,(ly:make-unpure-pure-container ly:rest::height ly:rest::pure-height)) - (Y-offset . ,(ly:make-unpure-pure-container ly:rest::y-offset-callback)) - (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) - (meta . ((class . Item) - (interfaces . (font-interface - rest-interface - rhythmic-grob-interface - rhythmic-head-interface - staff-symbol-referencer-interface)))))) + (cross-staff . ,ly:rest::calc-cross-staff) + (duration-log . ,stem::calc-duration-log) + (minimum-distance . 0.25) + (stencil . ,ly:rest::print) + (X-extent . ,ly:rest::width) + (Y-extent . ,(ly:make-unpure-pure-container ly:rest::height ly:rest::pure-height)) + (Y-offset . ,(ly:make-unpure-pure-container ly:rest::y-offset-callback)) + (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) + (meta . ((class . Item) + (interfaces . (font-interface + rest-interface + rhythmic-grob-interface + rhythmic-head-interface + staff-symbol-referencer-interface)))))) (RestCollision . ( - (minimum-distance . 0.75) - (positioning-done . ,ly:rest-collision::calc-positioning-done) - (meta . ((class . Item) - (interfaces . (rest-collision-interface)))))) + (minimum-distance . 0.75) + (positioning-done . ,ly:rest-collision::calc-positioning-done) + (meta . ((class . Item) + (interfaces . (rest-collision-interface)))))) (Script . ( - (add-stem-support . #t) - (cross-staff . ,ly:script-interface::calc-cross-staff) - (direction . ,ly:script-interface::calc-direction) - (font-encoding . fetaMusic) - (positioning-done . ,ly:script-interface::calc-positioning-done) - (side-axis . ,Y) - - ;; padding set in script definitions. - (slur-padding . 0.2) - (staff-padding . 0.25) - - (stencil . ,ly:script-interface::print) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (X-offset . ,script-interface::calc-x-offset) - (Y-offset . ,side-position-interface::y-aligned-side) - (meta . ((class . Item) - (interfaces . (font-interface - script-interface - side-position-interface)))))) + (add-stem-support . #t) + (cross-staff . ,ly:script-interface::calc-cross-staff) + (direction . ,ly:script-interface::calc-direction) + (font-encoding . fetaMusic) + (positioning-done . ,ly:script-interface::calc-positioning-done) + (side-axis . ,Y) + + ;; padding set in script definitions. + (slur-padding . 0.2) + (staff-padding . 0.25) + + (stencil . ,ly:script-interface::print) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (X-offset . ,script-interface::calc-x-offset) + (Y-offset . ,side-position-interface::y-aligned-side) + (meta . ((class . Item) + (interfaces . (font-interface + script-interface + side-position-interface)))))) (ScriptColumn . ( - (before-line-breaking . ,ly:script-column::before-line-breaking) - (meta . ((class . Item) - (interfaces . (script-column-interface)))))) + (before-line-breaking . ,ly:script-column::before-line-breaking) + (meta . ((class . Item) + (interfaces . (script-column-interface)))))) (ScriptRow . ( - (before-line-breaking . ,ly:script-column::row-before-line-breaking) - (meta . ((class . Item) - (interfaces . (script-column-interface)))))) + (before-line-breaking . ,ly:script-column::row-before-line-breaking) + (meta . ((class . Item) + (interfaces . (script-column-interface)))))) (Slur . ( - (avoid-slur . inside) - (control-points . ,ly:slur::calc-control-points) - (cross-staff . ,ly:slur::calc-cross-staff) - (details . ,default-slur-details) - (direction . ,ly:slur::calc-direction) - (height-limit . 2.0) - (line-thickness . 0.8) - (minimum-length . 1.5) - (ratio . 0.25) - (spanner-id . "") - (springs-and-rods . ,ly:spanner::set-spacing-rods) - (stencil . ,ly:slur::print) - (thickness . 1.2) - (vertical-skylines . ,(ly:make-unpure-pure-container ly:slur::vertical-skylines ly:grob::pure-simple-vertical-skylines-from-extents)) - (Y-extent . ,slur::height) - (meta . ((class . Spanner) - (interfaces . (slur-interface)))))) + (avoid-slur . inside) + (control-points . ,ly:slur::calc-control-points) + (cross-staff . ,ly:slur::calc-cross-staff) + (details . ,default-slur-details) + (direction . ,ly:slur::calc-direction) + (height-limit . 2.0) + (line-thickness . 0.8) + (minimum-length . 1.5) + (ratio . 0.25) + (spanner-id . "") + (springs-and-rods . ,ly:spanner::set-spacing-rods) + (stencil . ,ly:slur::print) + (thickness . 1.2) + (vertical-skylines . ,(ly:make-unpure-pure-container ly:slur::vertical-skylines ly:grob::pure-simple-vertical-skylines-from-extents)) + (Y-extent . ,slur::height) + (meta . ((class . Spanner) + (interfaces . (slur-interface)))))) (SostenutoPedal . ( - (direction . ,RIGHT) - (extra-spacing-width . (+inf.0 . -inf.0)) - (font-shape . italic) - (padding . 0.0) ;; padding relative to SostenutoPedalLineSpanner - (self-alignment-X . ,CENTER) - (stencil . ,ly:text-interface::print) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - (X-offset . ,ly:self-alignment-interface::x-aligned-on-self) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (font-interface - piano-pedal-script-interface - self-alignment-interface - text-interface)))))) + (direction . ,RIGHT) + (extra-spacing-width . (+inf.0 . -inf.0)) + (font-shape . italic) + (padding . 0.0) ;; padding relative to SostenutoPedalLineSpanner + (self-alignment-X . ,CENTER) + (stencil . ,ly:text-interface::print) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + (X-offset . ,ly:self-alignment-interface::x-aligned-on-self) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (font-interface + piano-pedal-script-interface + self-alignment-interface + text-interface)))))) (SostenutoPedalLineSpanner . ( - (axes . (,Y)) - (cross-staff . ,ly:side-position-interface::calc-cross-staff) - (direction . ,DOWN) - (minimum-space . 1.0) - (outside-staff-priority . 1000) - (padding . 1.2) - (side-axis . ,Y) - (staff-padding . 1.0) - (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils) - (X-extent . ,ly:axis-group-interface::width) - (Y-extent . ,axis-group-interface::height) - (Y-offset . ,side-position-interface::y-aligned-side) - (meta . ((class . Spanner) - (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) - (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) - (interfaces . (axis-group-interface - piano-pedal-interface - side-position-interface)))))) + (axes . (,Y)) + (cross-staff . ,ly:side-position-interface::calc-cross-staff) + (direction . ,DOWN) + (minimum-space . 1.0) + (outside-staff-priority . 1000) + (padding . 1.2) + (side-axis . ,Y) + (staff-padding . 1.0) + (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils) + (X-extent . ,ly:axis-group-interface::width) + (Y-extent . ,axis-group-interface::height) + (Y-offset . ,side-position-interface::y-aligned-side) + (meta . ((class . Spanner) + (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) + (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) + (interfaces . (axis-group-interface + piano-pedal-interface + side-position-interface)))))) (SpacingSpanner . ( - (average-spacing-wishes . #t) - (base-shortest-duration . ,(ly:make-moment 3 16)) - (common-shortest-duration . ,ly:spacing-spanner::calc-common-shortest-duration) - (shortest-duration-space . 2.0) - (spacing-increment . 1.2) - (springs-and-rods . ,ly:spacing-spanner::set-springs) - (meta . ((class . Spanner) - (interfaces . (spacing-options-interface - spacing-spanner-interface)))))) + (average-spacing-wishes . #t) + (base-shortest-duration . ,(ly:make-moment 3 16)) + (common-shortest-duration . ,ly:spacing-spanner::calc-common-shortest-duration) + (shortest-duration-space . 2.0) + (spacing-increment . 1.2) + (springs-and-rods . ,ly:spacing-spanner::set-springs) + (meta . ((class . Spanner) + (interfaces . (spacing-options-interface + spacing-spanner-interface)))))) (SpanBar . ( - (allow-span-bar . #t) - (bar-extent . ,axis-group-interface::height) - (before-line-breaking . ,ly:span-bar::before-line-breaking) - (break-align-symbol . staff-bar) - (cross-staff . #t) - (glyph-name . ,ly:span-bar::calc-glyph-name) - (layer . 0) - (non-musical . #t) - (stencil . ,ly:span-bar::print) - (X-extent . ,ly:span-bar::width) - (Y-extent . (+inf.0 . -inf.0)) - (meta . ((class . Item) - (interfaces . (bar-line-interface - font-interface - span-bar-interface)))))) + (allow-span-bar . #t) + (bar-extent . ,axis-group-interface::height) + (before-line-breaking . ,ly:span-bar::before-line-breaking) + (break-align-symbol . staff-bar) + (cross-staff . #t) + (glyph-name . ,ly:span-bar::calc-glyph-name) + (layer . 0) + (non-musical . #t) + (stencil . ,ly:span-bar::print) + (X-extent . ,ly:span-bar::width) + (Y-extent . (+inf.0 . -inf.0)) + (meta . ((class . Item) + (interfaces . (bar-line-interface + font-interface + span-bar-interface)))))) (SpanBarStub . ( (X-extent . ,(grob::inherit-parent-property X 'X-extent)) - (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height) - ; we want this to be ignored, so empty, but the extra spacing height - ; should preserve the span bar's presence for horizontal spacing - (Y-extent . ,pure-from-neighbor-interface::height-if-pure) - (meta . ((class . Item) - (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) - (pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs))) - (interfaces . (pure-from-neighbor-interface)))))) + (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height) + ; we want this to be ignored, so empty, but the extra spacing height + ; should preserve the span bar's presence for horizontal spacing + (Y-extent . ,pure-from-neighbor-interface::height-if-pure) + (meta . ((class . Item) + (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) + (pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs))) + (interfaces . (pure-from-neighbor-interface)))))) (StaffGrouper . ( - (staff-staff-spacing . ((basic-distance . 9) - (minimum-distance . 7) - (padding . 1) + (staff-staff-spacing . ((basic-distance . 9) + (minimum-distance . 7) + (padding . 1) (stretchability . 5))) - (staffgroup-staff-spacing . ((basic-distance . 10.5) - (minimum-distance . 8) - (padding . 1) + (staffgroup-staff-spacing . ((basic-distance . 10.5) + (minimum-distance . 8) + (padding . 1) (stretchability . 9))) - (meta . ((class . Spanner) - (interfaces . (staff-grouper-interface)))))) + (meta . ((class . Spanner) + (interfaces . (staff-grouper-interface)))))) (StaffSpacing . ( - (non-musical . #t) - (stem-spacing-correction . 0.4) - (meta . ((class . Item) - (interfaces . (spacing-interface - staff-spacing-interface)))))) + (non-musical . #t) + (stem-spacing-correction . 0.4) + (meta . ((class . Item) + (interfaces . (spacing-interface + staff-spacing-interface)))))) (StaffSymbol . ( - (layer . 0) - (ledger-line-thickness . (1.0 . 0.1)) - (line-count . 5) - (stencil . ,ly:staff-symbol::print) - (Y-extent . ,(ly:make-unpure-pure-container ly:staff-symbol::height)) - (meta . ((class . Spanner) - (interfaces . (staff-symbol-interface)))))) + (layer . 0) + (ledger-line-thickness . (1.0 . 0.1)) + (line-count . 5) + (stencil . ,ly:staff-symbol::print) + (Y-extent . ,(ly:make-unpure-pure-container ly:staff-symbol::height)) + (meta . ((class . Spanner) + (interfaces . (staff-symbol-interface)))))) (StanzaNumber . ( - (direction . ,LEFT) - (font-series . bold) - (padding . 1.0) - (side-axis . ,X) - (stencil . ,ly:text-interface::print) - (X-offset . ,ly:side-position-interface::x-aligned-side) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (font-interface - side-position-interface - stanza-number-interface - text-interface)))))) + (direction . ,LEFT) + (font-series . bold) + (padding . 1.0) + (side-axis . ,X) + (stencil . ,ly:text-interface::print) + (X-offset . ,ly:side-position-interface::x-aligned-side) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (font-interface + side-position-interface + stanza-number-interface + text-interface)))))) (Stem . ( - (beamlet-default-length . (1.1 . 1.1)) - (beamlet-max-length-proportion . (0.75 . 0.75)) - (cross-staff . ,ly:stem::calc-cross-staff) - (default-direction . ,ly:stem::calc-default-direction) - (details - . ( - ;; 3.5 (or 3 measured from note head) is standard length - ;; 32nd, 64th, 128th flagged stems should be longer - (lengths . (3.5 3.5 3.5 4.25 5.0 6.0)) + (beamlet-default-length . (1.1 . 1.1)) + (beamlet-max-length-proportion . (0.75 . 0.75)) + (cross-staff . ,ly:stem::calc-cross-staff) + (default-direction . ,ly:stem::calc-default-direction) + (details + . ( + ;; 3.5 (or 3 measured from note head) is standard length + ;; 32nd, 64th, 128th flagged stems should be longer + (lengths . (3.5 3.5 3.5 4.25 5.0 6.0)) - ;; FIXME. 3.5 yields too long beams (according to Ross and - ;; looking at Baerenreiter examples) for a number of common - ;; boundary cases. Subtracting half a beam thickness fixes - ;; this, but the bug may well be somewhere else. + ;; FIXME. 3.5 yields too long beams (according to Ross and + ;; looking at Baerenreiter examples) for a number of common + ;; boundary cases. Subtracting half a beam thickness fixes + ;; this, but the bug may well be somewhere else. - ;; FIXME this should come from 'lengths - (beamed-lengths . (3.26 3.5 3.6)) + ;; FIXME this should come from 'lengths + (beamed-lengths . (3.26 3.5 3.6)) - ;; The 'normal' minima - (beamed-minimum-free-lengths . (1.83 1.5 1.25)) - ;(beamed-minimum-free-lengths . (2.0 1.83 1.25)) + ;; The 'normal' minima + (beamed-minimum-free-lengths . (1.83 1.5 1.25)) + ;(beamed-minimum-free-lengths . (2.0 1.83 1.25)) - ;; The 'extreme case' minima - (beamed-extreme-minimum-free-lengths . (2.0 1.25)) + ;; The 'extreme case' minima + (beamed-extreme-minimum-free-lengths . (2.0 1.25)) - ;; Stems in unnatural (forced) direction should be shortened by - ;; one staff space, according to [Roush & Gourlay]. - ;; Flagged stems we shorten only half a staff space. - (stem-shorten . (1.0 0.5)) + ;; Stems in unnatural (forced) direction should be shortened by + ;; one staff space, according to [Roush & Gourlay]. + ;; Flagged stems we shorten only half a staff space. + (stem-shorten . (1.0 0.5)) - )) + )) - ;; We use the normal minima as minimum for the ideal lengths, - ;; and the extreme minima as abolute minimum length. + ;; We use the normal minima as minimum for the ideal lengths, + ;; and the extreme minima as abolute minimum length. - (direction . ,ly:stem::calc-direction) - (duration-log . ,stem::calc-duration-log) + (direction . ,ly:stem::calc-direction) + (duration-log . ,stem::calc-duration-log) (length . ,(ly:make-unpure-pure-container ly:stem::calc-length ly:stem::pure-calc-length)) - (neutral-direction . ,DOWN) - (positioning-done . ,ly:stem::calc-positioning-done) - (stem-info . ,ly:stem::calc-stem-info) - (stem-begin-position . ,(ly:make-unpure-pure-container ly:stem::calc-stem-begin-position ly:stem::pure-calc-stem-begin-position)) - (stencil . ,ly:stem::print) - (thickness . 1.3) - (X-extent . ,ly:stem::width) - (X-offset . ,ly:stem::offset-callback) - (Y-extent . ,(ly:make-unpure-pure-container ly:stem::height ly:stem::pure-height)) - (Y-offset . ,staff-symbol-referencer::callback) - (meta . ((class . Item) - (interfaces . (stem-interface)))))) + (neutral-direction . ,DOWN) + (positioning-done . ,ly:stem::calc-positioning-done) + (stem-info . ,ly:stem::calc-stem-info) + (stem-begin-position . ,(ly:make-unpure-pure-container ly:stem::calc-stem-begin-position ly:stem::pure-calc-stem-begin-position)) + (stencil . ,ly:stem::print) + (thickness . 1.3) + (X-extent . ,ly:stem::width) + (X-offset . ,ly:stem::offset-callback) + (Y-extent . ,(ly:make-unpure-pure-container ly:stem::height ly:stem::pure-height)) + (Y-offset . ,staff-symbol-referencer::callback) + (meta . ((class . Item) + (interfaces . (stem-interface)))))) (StemStub . ( (X-extent . ,stem-stub::width) - (extra-spacing-height . ,stem-stub::extra-spacing-height) - (Y-extent . ,(ly:make-unpure-pure-container #f stem-stub::pure-height)) - (meta . ((class . Item) - (interfaces . ()))))) + (extra-spacing-height . ,stem-stub::extra-spacing-height) + (Y-extent . ,(ly:make-unpure-pure-container #f stem-stub::pure-height)) + (meta . ((class . Item) + (interfaces . ()))))) (StemTremolo . ( - (beam-thickness . 0.48) ; staff-space - (beam-width . ,ly:stem-tremolo::calc-width) ; staff-space - (direction . ,ly:stem-tremolo::calc-direction) - (slope . ,ly:stem-tremolo::calc-slope) - (stencil . ,ly:stem-tremolo::print) - (style . ,ly:stem-tremolo::calc-style) - (X-extent . ,ly:stem-tremolo::width) - (Y-extent . ,(grob::unpure-Y-extent-from-stencil ly:stem-tremolo::pure-height)) - (X-offset . ,(ly:make-simple-closure - `(,+ - ,(ly:make-simple-closure - (list ly:self-alignment-interface::centered-on-x-parent)) - ,(ly:make-simple-closure - (list ly:self-alignment-interface::x-aligned-on-self))))) + (beam-thickness . 0.48) ; staff-space + (beam-width . ,ly:stem-tremolo::calc-width) ; staff-space + (direction . ,ly:stem-tremolo::calc-direction) + (slope . ,ly:stem-tremolo::calc-slope) + (stencil . ,ly:stem-tremolo::print) + (style . ,ly:stem-tremolo::calc-style) + (X-extent . ,ly:stem-tremolo::width) + (Y-extent . ,(grob::unpure-Y-extent-from-stencil ly:stem-tremolo::pure-height)) + (X-offset . ,(ly:make-simple-closure + `(,+ + ,(ly:make-simple-closure + (list ly:self-alignment-interface::centered-on-x-parent)) + ,(ly:make-simple-closure + (list ly:self-alignment-interface::x-aligned-on-self))))) (Y-offset . ,(ly:make-unpure-pure-container ly:stem-tremolo::calc-y-offset ly:stem-tremolo::pure-calc-y-offset)) - (meta . ((class . Item) - (interfaces . (self-alignment-interface + (meta . ((class . Item) + (interfaces . (self-alignment-interface stem-tremolo-interface)))))) (StringNumber . ( - (avoid-slur . around) - (cross-staff . ,script-or-side-position-cross-staff) - (font-encoding . fetaText) - (font-size . -5) ; don't overlap when next to heads. - (padding . 0.5) - (script-priority . 100) - (self-alignment-X . ,CENTER) - (self-alignment-Y . ,CENTER) - (staff-padding . 0.5) - (stencil . ,print-circled-text-callback) - (text . ,string-number::calc-text) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (font-interface - self-alignment-interface - side-position-interface - string-number-interface - text-interface - text-script-interface)))))) + (avoid-slur . around) + (cross-staff . ,script-or-side-position-cross-staff) + (font-encoding . fetaText) + (font-size . -5) ; don't overlap when next to heads. + (padding . 0.5) + (script-priority . 100) + (self-alignment-X . ,CENTER) + (self-alignment-Y . ,CENTER) + (staff-padding . 0.5) + (stencil . ,print-circled-text-callback) + (text . ,string-number::calc-text) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (font-interface + self-alignment-interface + side-position-interface + string-number-interface + text-interface + text-script-interface)))))) (StrokeFinger . ( - (digit-names . #("p" "i" "m" "a" "x")) - (font-shape . italic) - (font-size . -4) ; don't overlap when next to heads. - (padding . 0.5) - (script-priority . 100) - (self-alignment-X . ,CENTER) - (self-alignment-Y . ,CENTER) - (staff-padding . 0.5) - (stencil . ,ly:text-interface::print) - (text . ,stroke-finger::calc-text) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (font-interface - self-alignment-interface - side-position-interface - stroke-finger-interface - text-interface - text-script-interface)))))) + (digit-names . #("p" "i" "m" "a" "x")) + (font-shape . italic) + (font-size . -4) ; don't overlap when next to heads. + (padding . 0.5) + (script-priority . 100) + (self-alignment-X . ,CENTER) + (self-alignment-Y . ,CENTER) + (staff-padding . 0.5) + (stencil . ,ly:text-interface::print) + (text . ,stroke-finger::calc-text) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (font-interface + self-alignment-interface + side-position-interface + stroke-finger-interface + text-interface + text-script-interface)))))) (SustainPedal . ( - (direction . ,RIGHT) - (extra-spacing-width . (+inf.0 . -inf.0)) - (padding . 0.0) ;; padding relative to SustainPedalLineSpanner - (self-alignment-X . ,CENTER) - (stencil . ,ly:sustain-pedal::print) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - (X-offset . ,ly:self-alignment-interface::x-aligned-on-self) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (font-interface - piano-pedal-interface - piano-pedal-script-interface - self-alignment-interface - text-interface)))))) + (direction . ,RIGHT) + (extra-spacing-width . (+inf.0 . -inf.0)) + (padding . 0.0) ;; padding relative to SustainPedalLineSpanner + (self-alignment-X . ,CENTER) + (stencil . ,ly:sustain-pedal::print) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + (X-offset . ,ly:self-alignment-interface::x-aligned-on-self) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (font-interface + piano-pedal-interface + piano-pedal-script-interface + self-alignment-interface + text-interface)))))) (SustainPedalLineSpanner . ( - (axes . (,Y)) - (cross-staff . ,ly:side-position-interface::calc-cross-staff) - (direction . ,DOWN) - (minimum-space . 1.0) - (outside-staff-priority . 1000) - (padding . 1.2) - (side-axis . ,Y) - (staff-padding . 1.2) - (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils) - (X-extent . ,ly:axis-group-interface::width) - (Y-extent . ,axis-group-interface::height) - (Y-offset . ,side-position-interface::y-aligned-side) - (meta . ((class . Spanner) - (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) - (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) - (interfaces . (axis-group-interface - piano-pedal-interface - side-position-interface)))))) + (axes . (,Y)) + (cross-staff . ,ly:side-position-interface::calc-cross-staff) + (direction . ,DOWN) + (minimum-space . 1.0) + (outside-staff-priority . 1000) + (padding . 1.2) + (side-axis . ,Y) + (staff-padding . 1.2) + (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils) + (X-extent . ,ly:axis-group-interface::width) + (Y-extent . ,axis-group-interface::height) + (Y-offset . ,side-position-interface::y-aligned-side) + (meta . ((class . Spanner) + (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) + (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) + (interfaces . (axis-group-interface + piano-pedal-interface + side-position-interface)))))) (System . ( - (adjacent-pure-heights . ,ly:axis-group-interface::adjacent-pure-heights) - (axes . (,X ,Y)) - (outside-staff-placement-directive . left-to-right-polite) - (skyline-horizontal-padding . 1.0) - (vertical-skylines . ,ly:axis-group-interface::calc-skylines) - (X-extent . ,ly:axis-group-interface::width) - (Y-extent . ,(ly:make-unpure-pure-container ly:system::height ly:system::calc-pure-height)) - (meta . ((class . System) - (object-callbacks . ((footnotes-before-line-breaking . ,ly:system::footnotes-before-line-breaking) - (footnotes-after-line-breaking . ,ly:system::footnotes-after-line-breaking) - (pure-relevant-grobs . ,ly:system::calc-pure-relevant-grobs) - (pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) - (vertical-skyline-elements . ,ly:system::vertical-skyline-elements) + (adjacent-pure-heights . ,ly:axis-group-interface::adjacent-pure-heights) + (axes . (,X ,Y)) + (outside-staff-placement-directive . left-to-right-polite) + (skyline-horizontal-padding . 1.0) + (vertical-skylines . ,ly:axis-group-interface::calc-skylines) + (X-extent . ,ly:axis-group-interface::width) + (Y-extent . ,(ly:make-unpure-pure-container ly:system::height ly:system::calc-pure-height)) + (meta . ((class . System) + (object-callbacks . ((footnotes-before-line-breaking . ,ly:system::footnotes-before-line-breaking) + (footnotes-after-line-breaking . ,ly:system::footnotes-after-line-breaking) + (pure-relevant-grobs . ,ly:system::calc-pure-relevant-grobs) + (pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) + (vertical-skyline-elements . ,ly:system::vertical-skyline-elements) (vertical-alignment . ,ly:system::get-vertical-alignment))) - (interfaces . (axis-group-interface - system-interface)))))) + (interfaces . (axis-group-interface + system-interface)))))) (SystemStartBar . ( - (collapse-height . 5.0) - (direction . ,LEFT) - - (cross-staff . #t) - ;; ugh--hardcoded. - (padding . -0.1) ;; bar must cover rounded ending of staff line. - (stencil . ,ly:system-start-delimiter::print) - (style . bar-line) - (thickness . 1.6) - (X-offset . ,ly:side-position-interface::x-aligned-side) - (Y-extent . #f) - (meta . ((class . Spanner) - (interfaces . (side-position-interface - system-start-delimiter-interface)))))) + (collapse-height . 5.0) + (direction . ,LEFT) + + (cross-staff . #t) + ;; ugh--hardcoded. + (padding . -0.1) ;; bar must cover rounded ending of staff line. + (stencil . ,ly:system-start-delimiter::print) + (style . bar-line) + (thickness . 1.6) + (X-offset . ,ly:side-position-interface::x-aligned-side) + (Y-extent . #f) + (meta . ((class . Spanner) + (interfaces . (side-position-interface + system-start-delimiter-interface)))))) (SystemStartBrace . ( - (collapse-height . 5.0) - (direction . ,LEFT) - (font-encoding . fetaBraces) - (cross-staff . #t) - (padding . 0.3) - (stencil . ,ly:system-start-delimiter::print) - (style . brace) - (X-offset . ,ly:side-position-interface::x-aligned-side) - (Y-extent . #f) - (meta . ((class . Spanner) - (interfaces . (font-interface - side-position-interface - system-start-delimiter-interface)))))) + (collapse-height . 5.0) + (direction . ,LEFT) + (font-encoding . fetaBraces) + (cross-staff . #t) + (padding . 0.3) + (stencil . ,ly:system-start-delimiter::print) + (style . brace) + (X-offset . ,ly:side-position-interface::x-aligned-side) + (Y-extent . #f) + (meta . ((class . Spanner) + (interfaces . (font-interface + side-position-interface + system-start-delimiter-interface)))))) (SystemStartBracket . ( - (collapse-height . 5.0) - (direction . ,LEFT) - (cross-staff . #t) - (padding . 0.8) - (stencil . ,ly:system-start-delimiter::print) - (style . bracket) - (thickness . 0.45) - (X-offset . ,ly:side-position-interface::x-aligned-side) - (Y-extent . #f) - (meta . ((class . Spanner) - (interfaces . (font-interface - side-position-interface - system-start-delimiter-interface)))))) + (collapse-height . 5.0) + (direction . ,LEFT) + (cross-staff . #t) + (padding . 0.8) + (stencil . ,ly:system-start-delimiter::print) + (style . bracket) + (thickness . 0.45) + (X-offset . ,ly:side-position-interface::x-aligned-side) + (Y-extent . #f) + (meta . ((class . Spanner) + (interfaces . (font-interface + side-position-interface + system-start-delimiter-interface)))))) (SystemStartSquare . ( - (direction . ,LEFT) - (cross-staff . #t) - (stencil . ,ly:system-start-delimiter::print) - (style . line-bracket) - (thickness . 1.0) - (X-offset . ,ly:side-position-interface::x-aligned-side) - (Y-extent . #f) - (meta . ((class . Spanner) - (interfaces . (font-interface - side-position-interface - system-start-delimiter-interface)))))) + (direction . ,LEFT) + (cross-staff . #t) + (stencil . ,ly:system-start-delimiter::print) + (style . line-bracket) + (thickness . 1.0) + (X-offset . ,ly:side-position-interface::x-aligned-side) + (Y-extent . #f) + (meta . ((class . Spanner) + (interfaces . (font-interface + side-position-interface + system-start-delimiter-interface)))))) (TabNoteHead . ( - (details . ((cautionary-properties . ((angularity . 0.4) - (half-thickness . 0.075) - (padding . 0) - (procedure . ,parenthesize-stencil) - (width . 0.25))) - (head-offset . 3/5) - (harmonic-properties . ((angularity . 2) - (half-thickness . 0.075) - (padding . 0) - (procedure . ,parenthesize-stencil) - (width . 0.25))) - (repeat-tied-properties . ((note-head-visible . #t) - (parenthesize . #t))) - (tied-properties . ((break-visibility . ,begin-of-line-visible) - (parenthesize . #t))))) - - (direction . ,CENTER) - (duration-log . ,note-head::calc-duration-log) - (font-series . bold) - (font-size . -2) - (stem-attachment . (0.0 . 1.35)) - (stencil . ,tab-note-head::print) - (whiteout . #t) - (X-offset . ,ly:self-alignment-interface::x-aligned-on-self) - (Y-offset . ,staff-symbol-referencer::callback) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (font-interface - note-head-interface - rhythmic-grob-interface - rhythmic-head-interface - staff-symbol-referencer-interface - tab-note-head-interface - text-interface)))))) + (details . ((cautionary-properties . ((angularity . 0.4) + (half-thickness . 0.075) + (padding . 0) + (procedure . ,parenthesize-stencil) + (width . 0.25))) + (head-offset . 3/5) + (harmonic-properties . ((angularity . 2) + (half-thickness . 0.075) + (padding . 0) + (procedure . ,parenthesize-stencil) + (width . 0.25))) + (repeat-tied-properties . ((note-head-visible . #t) + (parenthesize . #t))) + (tied-properties . ((break-visibility . ,begin-of-line-visible) + (parenthesize . #t))))) + + (direction . ,CENTER) + (duration-log . ,note-head::calc-duration-log) + (font-series . bold) + (font-size . -2) + (stem-attachment . (0.0 . 1.35)) + (stencil . ,tab-note-head::print) + (whiteout . #t) + (X-offset . ,ly:self-alignment-interface::x-aligned-on-self) + (Y-offset . ,staff-symbol-referencer::callback) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (font-interface + note-head-interface + rhythmic-grob-interface + rhythmic-head-interface + staff-symbol-referencer-interface + tab-note-head-interface + text-interface)))))) (TextScript . ( - (avoid-slur . around) - (cross-staff . ,script-or-side-position-cross-staff) - (direction . ,DOWN) - (extra-spacing-width . (+inf.0 . -inf.0)) - (outside-staff-horizontal-padding . 0.12) - (outside-staff-priority . 450) - - ;; sync with Fingering ? - (padding . 0.3) - - (script-priority . 200) - (side-axis . ,Y) - (slur-padding . 0.5) - (staff-padding . 0.5) - (stencil . ,ly:text-interface::print) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - ;; todo: add X self alignment? - (Y-extent . ,grob::always-Y-extent-from-stencil) - (X-offset . ,ly:self-alignment-interface::x-aligned-on-self) - (Y-offset . ,side-position-interface::y-aligned-side) - (meta . ((class . Item) - (interfaces . (font-interface - instrument-specific-markup-interface - self-alignment-interface - side-position-interface - text-interface - text-script-interface)))))) + (avoid-slur . around) + (cross-staff . ,script-or-side-position-cross-staff) + (direction . ,DOWN) + (extra-spacing-width . (+inf.0 . -inf.0)) + (outside-staff-horizontal-padding . 0.12) + (outside-staff-priority . 450) + + ;; sync with Fingering ? + (padding . 0.3) + + (script-priority . 200) + (side-axis . ,Y) + (slur-padding . 0.5) + (staff-padding . 0.5) + (stencil . ,ly:text-interface::print) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + ;; todo: add X self alignment? + (Y-extent . ,grob::always-Y-extent-from-stencil) + (X-offset . ,ly:self-alignment-interface::x-aligned-on-self) + (Y-offset . ,side-position-interface::y-aligned-side) + (meta . ((class . Item) + (interfaces . (font-interface + instrument-specific-markup-interface + self-alignment-interface + side-position-interface + text-interface + text-script-interface)))))) (TextSpanner . ( - (bound-details . ((left . ((Y . 0) - (padding . 0.25) - (attach-dir . ,LEFT) - )) - (left-broken . ((attach-dir . ,RIGHT))) - (right . ((Y . 0) - (padding . 0.25) - )) - )) - (dash-fraction . 0.2) - (dash-period . 3.0) - (direction . ,UP) - (font-shape . italic) - (left-bound-info . ,ly:line-spanner::calc-left-bound-info) - (outside-staff-priority . 350) - (right-bound-info . ,ly:line-spanner::calc-right-bound-info) - (side-axis . ,Y) - (staff-padding . 0.8) - (stencil . ,ly:line-spanner::print) - (style . dashed-line) - (Y-offset . ,side-position-interface::y-aligned-side) - - (meta . ((class . Spanner) - (interfaces . (font-interface - line-interface - line-spanner-interface - side-position-interface)))))) + (bound-details . ((left . ((Y . 0) + (padding . 0.25) + (attach-dir . ,LEFT) + )) + (left-broken . ((attach-dir . ,RIGHT))) + (right . ((Y . 0) + (padding . 0.25) + )) + )) + (dash-fraction . 0.2) + (dash-period . 3.0) + (direction . ,UP) + (font-shape . italic) + (left-bound-info . ,ly:line-spanner::calc-left-bound-info) + (outside-staff-priority . 350) + (right-bound-info . ,ly:line-spanner::calc-right-bound-info) + (side-axis . ,Y) + (staff-padding . 0.8) + (stencil . ,ly:line-spanner::print) + (style . dashed-line) + (Y-offset . ,side-position-interface::y-aligned-side) + + (meta . ((class . Spanner) + (interfaces . (font-interface + line-interface + line-spanner-interface + side-position-interface)))))) (Tie . ( - (avoid-slur . inside) - (control-points . ,ly:tie::calc-control-points) - (details . ( - ;; for a full list, see tie-details.cc - (ratio . 0.333) - (center-staff-line-clearance . 0.6) - (tip-staff-line-clearance . 0.45) - (note-head-gap . 0.2) - (stem-gap . 0.35) - (height-limit . 1.0) - (horizontal-distance-penalty-factor . 10) - (same-dir-as-stem-penalty . 8) - (min-length-penalty-factor . 26) - (tie-tie-collision-distance . 0.45) - (tie-tie-collision-penalty . 25.0) - (intra-space-threshold . 1.25) - (outer-tie-vertical-distance-symmetry-penalty-factor . 10) - (outer-tie-length-symmetry-penalty-factor . 10) - (vertical-distance-penalty-factor . 7) - (outer-tie-vertical-gap . 0.25) - (multi-tie-region-size . 3) - (single-tie-region-size . 4) - (between-length-limit . 1.0))) - - (direction . ,ly:tie::calc-direction) - (font-size . -6) - (line-thickness . 0.8) - (neutral-direction . ,UP) - (springs-and-rods . ,ly:spanner::set-spacing-rods) - (stencil . ,ly:tie::print) - (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) - (thickness . 1.2) - (meta . ((class . Spanner) - (interfaces . (tie-interface)))))) + (avoid-slur . inside) + (control-points . ,ly:tie::calc-control-points) + (details . ( + ;; for a full list, see tie-details.cc + (ratio . 0.333) + (center-staff-line-clearance . 0.6) + (tip-staff-line-clearance . 0.45) + (note-head-gap . 0.2) + (stem-gap . 0.35) + (height-limit . 1.0) + (horizontal-distance-penalty-factor . 10) + (same-dir-as-stem-penalty . 8) + (min-length-penalty-factor . 26) + (tie-tie-collision-distance . 0.45) + (tie-tie-collision-penalty . 25.0) + (intra-space-threshold . 1.25) + (outer-tie-vertical-distance-symmetry-penalty-factor . 10) + (outer-tie-length-symmetry-penalty-factor . 10) + (vertical-distance-penalty-factor . 7) + (outer-tie-vertical-gap . 0.25) + (multi-tie-region-size . 3) + (single-tie-region-size . 4) + (between-length-limit . 1.0))) + + (direction . ,ly:tie::calc-direction) + (font-size . -6) + (line-thickness . 0.8) + (neutral-direction . ,UP) + (springs-and-rods . ,ly:spanner::set-spacing-rods) + (stencil . ,ly:tie::print) + (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) + (thickness . 1.2) + (meta . ((class . Spanner) + (interfaces . (tie-interface)))))) (TieColumn . ( - (before-line-breaking . ,ly:tie-column::before-line-breaking) - (positioning-done . ,ly:tie-column::calc-positioning-done) - (X-extent . #f) - (Y-extent . #f) - (meta . ((class . Spanner) - (interfaces . (tie-column-interface)))))) + (before-line-breaking . ,ly:tie-column::before-line-breaking) + (positioning-done . ,ly:tie-column::calc-positioning-done) + (X-extent . #f) + (Y-extent . #f) + (meta . ((class . Spanner) + (interfaces . (tie-column-interface)))))) (TimeSignature . ( - (avoid-slur . inside) - (break-align-anchor - . ,ly:break-aligned-interface::calc-extent-aligned-anchor) - (break-align-symbol . time-signature) - (break-align-anchor-alignment . ,LEFT) - (break-visibility . ,all-visible) - (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-including-staff) - (extra-spacing-width . (0.0 . 0.8)) - (non-musical . #t) - (space-alist . ( - (cue-clef . (extra-space . 1.5)) - (first-note . (fixed-space . 2.0)) - (right-edge . (extra-space . 0.5)) - (staff-bar . (extra-space . 1.0)))) - (stencil . ,ly:time-signature::print) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (style . C) - (meta . ((class . Item) + (avoid-slur . inside) + (break-align-anchor + . ,ly:break-aligned-interface::calc-extent-aligned-anchor) + (break-align-symbol . time-signature) + (break-align-anchor-alignment . ,LEFT) + (break-visibility . ,all-visible) + (extra-spacing-height . ,pure-from-neighbor-interface::extra-spacing-height-including-staff) + (extra-spacing-width . (0.0 . 0.8)) + (non-musical . #t) + (space-alist . ( + (cue-clef . (extra-space . 1.5)) + (first-note . (fixed-space . 2.0)) + (right-edge . (extra-space . 0.5)) + (staff-bar . (extra-space . 1.0)))) + (stencil . ,ly:time-signature::print) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (style . C) + (meta . ((class . Item) (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) (pure-relevant-grobs . ,ly:pure-from-neighbor-interface::calc-pure-relevant-grobs))) - (interfaces . (break-aligned-interface - font-interface - pure-from-neighbor-interface - time-signature-interface)))))) + (interfaces . (break-aligned-interface + font-interface + pure-from-neighbor-interface + time-signature-interface)))))) (TrillPitchAccidental . ( - (direction . ,LEFT) - (font-size . -4) - (glyph-name-alist . ,standard-alteration-glyph-name-alist) - (padding . 0.2) - (side-axis . ,X) - (stencil . ,ly:accidental-interface::print) - (X-offset . ,ly:side-position-interface::x-aligned-side) - (Y-extent . ,accidental-interface::height) - (meta . ((class . Item) - (interfaces . (accidental-interface - font-interface - inline-accidental-interface - side-position-interface - trill-pitch-accidental-interface)))))) + (direction . ,LEFT) + (font-size . -4) + (glyph-name-alist . ,standard-alteration-glyph-name-alist) + (padding . 0.2) + (side-axis . ,X) + (stencil . ,ly:accidental-interface::print) + (X-offset . ,ly:side-position-interface::x-aligned-side) + (Y-extent . ,accidental-interface::height) + (meta . ((class . Item) + (interfaces . (accidental-interface + font-interface + inline-accidental-interface + side-position-interface + trill-pitch-accidental-interface)))))) (TrillPitchGroup . ( - (axes . (,X)) - (direction . ,RIGHT) - (font-size . -4) - (padding . 0.3) - (side-axis . ,X) - (stencil . ,parenthesize-elements) - (stencils . ,parentheses-item::calc-parenthesis-stencils) - (X-offset . ,ly:side-position-interface::x-aligned-side) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (axis-group-interface - font-interface - note-head-interface - parentheses-interface - side-position-interface)))))) + (axes . (,X)) + (direction . ,RIGHT) + (font-size . -4) + (padding . 0.3) + (side-axis . ,X) + (stencil . ,parenthesize-elements) + (stencils . ,parentheses-item::calc-parenthesis-stencils) + (X-offset . ,ly:side-position-interface::x-aligned-side) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (axis-group-interface + font-interface + note-head-interface + parentheses-interface + side-position-interface)))))) (TrillPitchHead . ( - (duration-log . 2) - (font-size . -4) - (stencil . ,ly:note-head::print) - (Y-offset . ,staff-symbol-referencer::callback) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (meta . ((class . Item) - (interfaces . (font-interface - ledgered-interface - pitched-trill-interface - rhythmic-head-interface - staff-symbol-referencer-interface)))))) + (duration-log . 2) + (font-size . -4) + (stencil . ,ly:note-head::print) + (Y-offset . ,staff-symbol-referencer::callback) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (meta . ((class . Item) + (interfaces . (font-interface + ledgered-interface + pitched-trill-interface + rhythmic-head-interface + staff-symbol-referencer-interface)))))) (TrillSpanner . ( - (after-line-breaking . ,ly:spanner::kill-zero-spanned-time) - (bound-details . ((left . ((text . ,(make-musicglyph-markup "scripts.trill")) - (Y . 0) - (stencil-offset . (-0.5 . -1)) - (padding . 0.5) - (attach-dir . ,CENTER) - )) - (left-broken . ((end-on-note . #t))) - (right . ((Y . 0))) - )) - (direction . ,UP) - (left-bound-info . ,ly:line-spanner::calc-left-bound-info) - (outside-staff-priority . 50) - (padding . 0.5) - (right-bound-info . ,ly:line-spanner::calc-right-bound-info) - (side-axis . ,Y) - (staff-padding . 1.0) - (stencil . ,ly:line-spanner::print) - (style . trill) - (Y-offset . ,side-position-interface::y-aligned-side) - (meta . ((class . Spanner) - (interfaces . (font-interface - line-interface - line-spanner-interface - side-position-interface - trill-spanner-interface)))))) + (after-line-breaking . ,ly:spanner::kill-zero-spanned-time) + (bound-details . ((left . ((text . ,(make-musicglyph-markup "scripts.trill")) + (Y . 0) + (stencil-offset . (-0.5 . -1)) + (padding . 0.5) + (attach-dir . ,CENTER) + )) + (left-broken . ((end-on-note . #t))) + (right . ((Y . 0))) + )) + (direction . ,UP) + (left-bound-info . ,ly:line-spanner::calc-left-bound-info) + (outside-staff-priority . 50) + (padding . 0.5) + (right-bound-info . ,ly:line-spanner::calc-right-bound-info) + (side-axis . ,Y) + (staff-padding . 1.0) + (stencil . ,ly:line-spanner::print) + (style . trill) + (Y-offset . ,side-position-interface::y-aligned-side) + (meta . ((class . Spanner) + (interfaces . (font-interface + line-interface + line-spanner-interface + side-position-interface + trill-spanner-interface)))))) (TupletBracket . ( - (avoid-scripts . #t) - (connect-to-neighbor . ,ly:tuplet-bracket::calc-connect-to-neighbors) - (cross-staff . ,ly:tuplet-bracket::calc-cross-staff) - (direction . ,ly:tuplet-bracket::calc-direction) - (edge-height . (0.7 . 0.7)) - (full-length-to-extent . #t) - (padding . 1.1) - (positions . ,ly:tuplet-bracket::calc-positions) - (shorten-pair . (-0.2 . -0.2)) - (staff-padding . 0.25) - (stencil . ,ly:tuplet-bracket::print) - (thickness . 1.6) - (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) - (X-positions . ,ly:tuplet-bracket::calc-x-positions) - - (meta . ((class . Spanner) - (interfaces . (line-interface - tuplet-bracket-interface)))))) + (avoid-scripts . #t) + (connect-to-neighbor . ,ly:tuplet-bracket::calc-connect-to-neighbors) + (cross-staff . ,ly:tuplet-bracket::calc-cross-staff) + (direction . ,ly:tuplet-bracket::calc-direction) + (edge-height . (0.7 . 0.7)) + (full-length-to-extent . #t) + (padding . 1.1) + (positions . ,ly:tuplet-bracket::calc-positions) + (shorten-pair . (-0.2 . -0.2)) + (staff-padding . 0.25) + (stencil . ,ly:tuplet-bracket::print) + (thickness . 1.6) + (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) + (X-positions . ,ly:tuplet-bracket::calc-x-positions) + + (meta . ((class . Spanner) + (interfaces . (line-interface + tuplet-bracket-interface)))))) (TupletNumber . ( - (avoid-slur . inside) - (cross-staff . ,ly:tuplet-number::calc-cross-staff) - (direction . ,tuplet-number::calc-direction) - (font-shape . italic) - (font-size . -2) - (stencil . ,ly:tuplet-number::print) - (text . ,tuplet-number::calc-denominator-text) - (X-offset . ,ly:tuplet-number::calc-x-offset) - (Y-offset . ,ly:tuplet-number::calc-y-offset) - (meta . ((class . Spanner) - (interfaces . (font-interface - text-interface - tuplet-number-interface)))))) + (avoid-slur . inside) + (cross-staff . ,ly:tuplet-number::calc-cross-staff) + (direction . ,tuplet-number::calc-direction) + (font-shape . italic) + (font-size . -2) + (stencil . ,ly:tuplet-number::print) + (text . ,tuplet-number::calc-denominator-text) + (X-offset . ,ly:tuplet-number::calc-x-offset) + (Y-offset . ,ly:tuplet-number::calc-y-offset) + (meta . ((class . Spanner) + (interfaces . (font-interface + text-interface + tuplet-number-interface)))))) (UnaCordaPedal . ( - (direction . ,RIGHT) - (extra-spacing-width . (+inf.0 . -inf.0)) - (font-shape . italic) - (padding . 0.0) ;; padding relative to UnaCordaPedalLineSpanner - (self-alignment-X . ,CENTER) - (stencil . ,ly:text-interface::print) - (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) - (Y-extent . ,grob::always-Y-extent-from-stencil) - (X-offset . ,ly:self-alignment-interface::x-aligned-on-self) - (meta . ((class . Item) - (interfaces . (font-interface - piano-pedal-script-interface - self-alignment-interface - text-interface)))))) + (direction . ,RIGHT) + (extra-spacing-width . (+inf.0 . -inf.0)) + (font-shape . italic) + (padding . 0.0) ;; padding relative to UnaCordaPedalLineSpanner + (self-alignment-X . ,CENTER) + (stencil . ,ly:text-interface::print) + (vertical-skylines . ,grob::always-vertical-skylines-from-stencil) + (Y-extent . ,grob::always-Y-extent-from-stencil) + (X-offset . ,ly:self-alignment-interface::x-aligned-on-self) + (meta . ((class . Item) + (interfaces . (font-interface + piano-pedal-script-interface + self-alignment-interface + text-interface)))))) (UnaCordaPedalLineSpanner . ( - (axes . (,Y)) - (cross-staff . ,ly:side-position-interface::calc-cross-staff) - (direction . ,DOWN) - (minimum-space . 1.0) - (outside-staff-priority . 1000) - (padding . 1.2) - (side-axis . ,Y) - (staff-padding . 1.2) - (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils) - (X-extent . ,ly:axis-group-interface::width) - (Y-extent . ,axis-group-interface::height) - (Y-offset . ,side-position-interface::y-aligned-side) - (meta . ((class . Spanner) - (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) - (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) - (interfaces . (axis-group-interface - piano-pedal-interface - side-position-interface)))))) + (axes . (,Y)) + (cross-staff . ,ly:side-position-interface::calc-cross-staff) + (direction . ,DOWN) + (minimum-space . 1.0) + (outside-staff-priority . 1000) + (padding . 1.2) + (side-axis . ,Y) + (staff-padding . 1.2) + (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils) + (X-extent . ,ly:axis-group-interface::width) + (Y-extent . ,axis-group-interface::height) + (Y-offset . ,side-position-interface::y-aligned-side) + (meta . ((class . Spanner) + (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) + (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) + (interfaces . (axis-group-interface + piano-pedal-interface + side-position-interface)))))) (VaticanaLigature . ( - (flexa-width . 2.0) - (stencil . ,ly:vaticana-ligature::print) - (thickness . 0.6) - (meta . ((class . Spanner) - (interfaces . (font-interface - vaticana-ligature-interface)))))) + (flexa-width . 2.0) + (stencil . ,ly:vaticana-ligature::print) + (thickness . 0.6) + (meta . ((class . Spanner) + (interfaces . (font-interface + vaticana-ligature-interface)))))) (VerticalAlignment . ( - (axes . (,Y)) - (positioning-done . ,ly:align-interface::align-to-ideal-distances) - (stacking-dir . -1) - (vertical-skylines . ,ly:axis-group-interface::combine-skylines) - (X-extent . ,ly:axis-group-interface::width) - (Y-extent . ,axis-group-interface::height) - (meta . ((class . Spanner) - (object-callbacks . ((Y-common . ,ly:axis-group-interface::calc-y-common) - (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs) - (pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common))) - (interfaces . (align-interface - axis-group-interface)))))) + (axes . (,Y)) + (positioning-done . ,ly:align-interface::align-to-ideal-distances) + (stacking-dir . -1) + (vertical-skylines . ,ly:axis-group-interface::combine-skylines) + (X-extent . ,ly:axis-group-interface::width) + (Y-extent . ,axis-group-interface::height) + (meta . ((class . Spanner) + (object-callbacks . ((Y-common . ,ly:axis-group-interface::calc-y-common) + (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs) + (pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common))) + (interfaces . (align-interface + axis-group-interface)))))) (VerticalAxisGroup . ( - (adjacent-pure-heights . ,ly:axis-group-interface::adjacent-pure-heights) - (axes . (,Y)) - (default-staff-staff-spacing . ((basic-distance . 9) - (minimum-distance . 8) - (padding . 1))) - (nonstaff-unrelatedstaff-spacing . ((padding . 0.5))) - (outside-staff-placement-directive . left-to-right-polite) - (staff-staff-spacing . ,(ly:make-unpure-pure-container ly:axis-group-interface::calc-staff-staff-spacing ly:axis-group-interface::calc-pure-staff-staff-spacing)) - (stencil . ,ly:axis-group-interface::print) - (skyline-horizontal-padding . 0.1) - (vertical-skylines . ,ly:hara-kiri-group-spanner::calc-skylines) - (X-extent . ,ly:axis-group-interface::width) - (Y-extent . ,(ly:make-unpure-pure-container ly:hara-kiri-group-spanner::y-extent ly:hara-kiri-group-spanner::pure-height)) - (Y-offset . ,ly:hara-kiri-group-spanner::force-hara-kiri-callback) - (meta . ((class . Spanner) - (object-callbacks . ( - (X-common . ,ly:axis-group-interface::calc-x-common) - (pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) - (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) - - (interfaces . (axis-group-interface - hara-kiri-group-spanner-interface)))))) + (adjacent-pure-heights . ,ly:axis-group-interface::adjacent-pure-heights) + (axes . (,Y)) + (default-staff-staff-spacing . ((basic-distance . 9) + (minimum-distance . 8) + (padding . 1))) + (nonstaff-unrelatedstaff-spacing . ((padding . 0.5))) + (outside-staff-placement-directive . left-to-right-polite) + (staff-staff-spacing . ,(ly:make-unpure-pure-container ly:axis-group-interface::calc-staff-staff-spacing ly:axis-group-interface::calc-pure-staff-staff-spacing)) + (stencil . ,ly:axis-group-interface::print) + (skyline-horizontal-padding . 0.1) + (vertical-skylines . ,ly:hara-kiri-group-spanner::calc-skylines) + (X-extent . ,ly:axis-group-interface::width) + (Y-extent . ,(ly:make-unpure-pure-container ly:hara-kiri-group-spanner::y-extent ly:hara-kiri-group-spanner::pure-height)) + (Y-offset . ,ly:hara-kiri-group-spanner::force-hara-kiri-callback) + (meta . ((class . Spanner) + (object-callbacks . ( + (X-common . ,ly:axis-group-interface::calc-x-common) + (pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) + (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) + + (interfaces . (axis-group-interface + hara-kiri-group-spanner-interface)))))) (VoiceFollower . ( - (after-line-breaking . ,ly:spanner::kill-zero-spanned-time) - (bound-details . ((right . ((attach-dir . ,CENTER) - (padding . 1.5) - )) - (left . ((attach-dir . ,CENTER) - (padding . 1.5) - )) - )) - (cross-staff . #t) - (gap . 0.5) - (left-bound-info . ,ly:line-spanner::calc-left-bound-info) - (non-musical . #t) - (right-bound-info . ,ly:line-spanner::calc-right-bound-info) - (stencil . ,ly:line-spanner::print) - (style . line) - (X-extent . #f) - (Y-extent . #f) - (meta . ((class . Spanner) - (interfaces . (line-interface - line-spanner-interface)))))) + (after-line-breaking . ,ly:spanner::kill-zero-spanned-time) + (bound-details . ((right . ((attach-dir . ,CENTER) + (padding . 1.5) + )) + (left . ((attach-dir . ,CENTER) + (padding . 1.5) + )) + )) + (cross-staff . #t) + (gap . 0.5) + (left-bound-info . ,ly:line-spanner::calc-left-bound-info) + (non-musical . #t) + (right-bound-info . ,ly:line-spanner::calc-right-bound-info) + (stencil . ,ly:line-spanner::print) + (style . line) + (X-extent . #f) + (Y-extent . #f) + (meta . ((class . Spanner) + (interfaces . (line-interface + line-spanner-interface)))))) (VoltaBracket . ( - (direction . ,UP) - (edge-height . (2.0 . 2.0)) ;; staff-space; - (font-encoding . fetaText) - (font-size . -4) - (shorten-pair . ,ly:volta-bracket::calc-shorten-pair) - (stencil . ,ly:volta-bracket-interface::print) - (thickness . 1.6) ;; line-thickness - (word-space . 0.6) - (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) - (Y-extent . ,(grob::unpure-Y-extent-from-stencil volta-bracket-interface::pure-height)) - (meta . ((class . Spanner) - (interfaces . (font-interface - horizontal-bracket-interface - line-interface - side-position-interface - text-interface - volta-bracket-interface - volta-interface)))))) + (direction . ,UP) + (edge-height . (2.0 . 2.0)) ;; staff-space; + (font-encoding . fetaText) + (font-size . -4) + (shorten-pair . ,ly:volta-bracket::calc-shorten-pair) + (stencil . ,ly:volta-bracket-interface::print) + (thickness . 1.6) ;; line-thickness + (word-space . 0.6) + (vertical-skylines . ,grob::unpure-vertical-skylines-from-stencil) + (Y-extent . ,(grob::unpure-Y-extent-from-stencil volta-bracket-interface::pure-height)) + (meta . ((class . Spanner) + (interfaces . (font-interface + horizontal-bracket-interface + line-interface + side-position-interface + text-interface + volta-bracket-interface + volta-interface)))))) (VoltaBracketSpanner . ( - (after-line-breaking . ,ly:side-position-interface::move-to-extremal-staff) - (axes . (,Y)) - (direction . ,UP) - (no-alignment . #t) - (outside-staff-priority . 600) - (padding . 1) - (side-axis . ,Y) - (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils) - (X-extent . ,ly:axis-group-interface::width) - (Y-extent . ,axis-group-interface::height) + (after-line-breaking . ,ly:side-position-interface::move-to-extremal-staff) + (axes . (,Y)) + (direction . ,UP) + (no-alignment . #t) + (outside-staff-priority . 600) + (padding . 1) + (side-axis . ,Y) + (vertical-skylines . ,grob::always-vertical-skylines-from-element-stencils) + (X-extent . ,ly:axis-group-interface::width) + (Y-extent . ,axis-group-interface::height) (Y-offset . ,side-position-interface::y-aligned-side) - (meta . ((class . Spanner) - (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) - (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) - (interfaces . (axis-group-interface - side-position-interface - volta-interface)))))) + (meta . ((class . Spanner) + (object-callbacks . ((pure-Y-common . ,ly:axis-group-interface::calc-pure-y-common) + (pure-relevant-grobs . ,ly:axis-group-interface::calc-pure-relevant-grobs))) + (interfaces . (axis-group-interface + side-position-interface + volta-interface)))))) -)) + )) (define (completize-grob-entry x) "Transplant assoc key into 'name entry of 'meta of X. Set interfaces for Item, Spanner etc. @@ -2759,11 +2759,11 @@ ;; (display (car x)) ;; (newline) (let* ((name-sym (car x)) - (grob-entry (cdr x)) - (meta-entry (assoc-get 'meta grob-entry)) - (class (assoc-get 'class meta-entry)) - (ifaces-entry - (assoc-get 'interfaces meta-entry))) + (grob-entry (cdr x)) + (meta-entry (assoc-get 'meta grob-entry)) + (class (assoc-get 'class meta-entry)) + (ifaces-entry + (assoc-get 'interfaces meta-entry))) (cond ((eq? 'Item class) @@ -2772,10 +2772,10 @@ (set! ifaces-entry (cons 'spanner-interface ifaces-entry))) ((eq? 'Paper_column class) (set! ifaces-entry (cons 'item-interface - (cons 'paper-column-interface ifaces-entry)))) + (cons 'paper-column-interface ifaces-entry)))) ((eq? 'System class) (set! ifaces-entry (cons 'system-interface - (cons 'spanner-interface ifaces-entry)))) + (cons 'spanner-interface ifaces-entry)))) (else (ly:warning "Unknown class ~a" class))) @@ -2784,7 +2784,7 @@ (set! meta-entry (assoc-set! meta-entry 'name name-sym)) (set! meta-entry (assoc-set! meta-entry 'interfaces - ifaces-entry)) + ifaces-entry)) (set! grob-entry (assoc-set! grob-entry 'meta meta-entry)) (cons name-sym grob-entry))) diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm index ecbe876ffa..fd7ce3eff8 100755 --- a/scm/define-markup-commands.scm +++ b/scm/define-markup-commands.scm @@ -194,40 +194,40 @@ Manual settings for @code{on},@code{off} and @code{phase} are possible. ;; line-length. (new-off (/ (- line-length corr (* (1+ guess) on)) guess)) ) - (cond - - ;; Settings for (= on 0). Resulting in a dotted line. - - ;; If line-length isn't shorter than `th´, change the given - ;; value for `off´ to fit the line-length. - ((and (= on 0) (< th line-length)) - (set! off new-off)) - - ;; If the line-length is shorter than `th´, it makes no - ;; sense to adjust `off´. The rounded edges of the lines - ;; would prevent any nice output. - ;; Do nothing. - ;; This will result in a single dot for very short lines. - ((and (= on 0) (>= th line-length)) - #f) - - ;; Settings for (not (= on 0)). Resulting in a dashed line. - - ;; If line-length isn't shorter than one go of on-off-on, - ;; change the given value for `off´ to fit the line-length. - ((< (+ (* 2 on) off) line-length) - (set! off new-off)) - ;; If the line-length is too short, but greater than - ;; (* 4 th) set on/off to (/ line-length 3) - ((< (* 4 th) line-length) - (set! on (/ line-length 3)) - (set! off (/ line-length 3))) - ;; If the line-length is shorter than (* 4 th), it makes - ;; no sense trying to adjust on/off. The rounded edges of - ;; the lines would prevent any nice output. - ;; Simply set `on´ to line-length. - (else - (set! on line-length)))))) + (cond + + ;; Settings for (= on 0). Resulting in a dotted line. + + ;; If line-length isn't shorter than `th´, change the given + ;; value for `off´ to fit the line-length. + ((and (= on 0) (< th line-length)) + (set! off new-off)) + + ;; If the line-length is shorter than `th´, it makes no + ;; sense to adjust `off´. The rounded edges of the lines + ;; would prevent any nice output. + ;; Do nothing. + ;; This will result in a single dot for very short lines. + ((and (= on 0) (>= th line-length)) + #f) + + ;; Settings for (not (= on 0)). Resulting in a dashed line. + + ;; If line-length isn't shorter than one go of on-off-on, + ;; change the given value for `off´ to fit the line-length. + ((< (+ (* 2 on) off) line-length) + (set! off new-off)) + ;; If the line-length is too short, but greater than + ;; (* 4 th) set on/off to (/ line-length 3) + ((< (* 4 th) line-length) + (set! on (/ line-length 3)) + (set! off (/ line-length 3))) + ;; If the line-length is shorter than (* 4 th), it makes + ;; no sense trying to adjust on/off. The rounded edges of + ;; the lines would prevent any nice output. + ;; Simply set `on´ to line-length. + (else + (set! on line-length)))))) ;; If `on´ or `off´ is negative, or the sum of `on' and `off' equals zero a ;; ghostscript-error occurs while calling @@ -244,9 +244,9 @@ Manual settings for @code{on},@code{off} and @code{phase} are possible. ;; To give the lines produced by \draw-line and \draw-dashed-line the same ;; length, half-thick has to be added to the stencil-extensions. (ly:make-stencil - (list 'dashed-line th on off x y phase) - (interval-widen (ordered-cons 0 x) half-thick) - (interval-widen (ordered-cons 0 y) half-thick)))) + (list 'dashed-line th on off x y phase) + (interval-widen (ordered-cons 0 x) half-thick) + (interval-widen (ordered-cons 0 y) half-thick)))) (define-markup-command (draw-dotted-line layout props dest) (number-pair?) @@ -275,11 +275,11 @@ line-length. @end lilypond" (let ((new-props (prepend-alist-chain 'on 0 - (prepend-alist-chain 'full-length #t props)))) + (prepend-alist-chain 'full-length #t props)))) - (interpret-markup layout - new-props - (markup #:draw-dashed-line dest)))) + (interpret-markup layout + new-props + (markup #:draw-dashed-line dest)))) (define-markup-command (draw-hline layout props) () @@ -304,8 +304,8 @@ controls what fraction of the page is taken up. (interpret-markup layout props (markup #:draw-line (cons (* line-width - span-factor) - 0)))) + span-factor) + 0)))) (define-markup-command (draw-circle layout props radius thickness filled) (number? number? boolean?) @@ -329,8 +329,8 @@ optionally filled. (boolean?) #:category graphic #:properties ((thickness 0.1) - (font-size 0) - (baseline-skip 2)) + (font-size 0) + (baseline-skip 2)) " @cindex drawing triangles within text @@ -349,8 +349,8 @@ A triangle, either filled or empty. ,ex 0.0 ,(* 0.5 ex) ,(* 0.86 ex)) - ,thickness - ,filled) + ,thickness + ,filled) (cons 0 ex) (cons 0 (* .86 ex))))) @@ -358,8 +358,8 @@ A triangle, either filled or empty. (markup?) #:category graphic #:properties ((thickness 1) - (font-size 0) - (circle-padding 0.2)) + (font-size 0) + (circle-padding 0.2)) " @cindex circling text @@ -376,8 +376,8 @@ thickness and padding around the markup. @end lilypond" (let ((th (* (ly:output-def-lookup layout 'line-thickness) thickness)) - (pad (* (magstep font-size) circle-padding)) - (m (interpret-markup layout props arg))) + (pad (* (magstep font-size) circle-padding)) + (m (interpret-markup layout props arg))) (circle-stencil m th pad))) (define-markup-command (with-url layout props url arg) @@ -399,10 +399,10 @@ the PDF backend. } @end lilypond" (let* ((stil (interpret-markup layout props arg)) - (xextent (ly:stencil-extent stil X)) - (yextent (ly:stencil-extent stil Y)) - (old-expr (ly:stencil-expr stil)) - (url-expr (list 'url-link url `(quote ,xextent) `(quote ,yextent)))) + (xextent (ly:stencil-extent stil X)) + (yextent (ly:stencil-extent stil Y)) + (old-expr (ly:stencil-expr stil)) + (url-expr (list 'url-link url `(quote ,xextent) `(quote ,yextent)))) (ly:stencil-add (ly:make-stencil url-expr xextent yextent) stil))) @@ -421,10 +421,10 @@ in the PDF backend. } @end lilypond" (let* ((stil (interpret-markup layout props arg)) - (xextent (ly:stencil-extent stil X)) - (yextent (ly:stencil-extent stil Y)) - (old-expr (ly:stencil-expr stil)) - (link-expr (list 'page-link page-number `(quote ,xextent) `(quote ,yextent)))) + (xextent (ly:stencil-extent stil X)) + (yextent (ly:stencil-extent stil Y)) + (old-expr (ly:stencil-expr stil)) + (link-expr (list 'page-link page-number `(quote ,xextent) `(quote ,yextent)))) (ly:stencil-add (ly:make-stencil link-expr xextent yextent) stil))) @@ -457,7 +457,7 @@ only works in the PDF backend. (link-expr (list 'page-link page-number `(quote ,x-ext) `(quote ,y-ext)))) (ly:stencil-add (ly:make-stencil link-expr x-ext y-ext) -arg-stencil))))) + arg-stencil))))) x-ext y-ext))) @@ -475,20 +475,20 @@ Create a beam with the specified parameters. } @end lilypond" (let* ((y (* slope width)) - (yext (cons (min 0 y) (max 0 y))) - (half (/ thickness 2))) + (yext (cons (min 0 y) (max 0 y))) + (half (/ thickness 2))) (ly:make-stencil `(polygon ',(list - 0 (/ thickness -2) - width (+ (* width slope) (/ thickness -2)) - width (+ (* width slope) (/ thickness 2)) - 0 (/ thickness 2)) - ,(ly:output-def-lookup layout 'blot-diameter) - #t) + 0 (/ thickness -2) + width (+ (* width slope) (/ thickness -2)) + width (+ (* width slope) (/ thickness 2)) + 0 (/ thickness 2)) + ,(ly:output-def-lookup layout 'blot-diameter) + #t) (cons 0 width) (cons (+ (- half) (car yext)) - (+ half (cdr yext)))))) + (+ half (cdr yext)))))) (define-markup-command (underline layout props arg) (markup?) @@ -524,8 +524,8 @@ thickness, and @code{offset} to determine line y-offset. (markup?) #:category font #:properties ((thickness 1) - (font-size 0) - (box-padding 0.2)) + (font-size 0) + (box-padding 0.2)) " @cindex enclosing text within a box @@ -578,9 +578,9 @@ circle of diameter@tie{}0 (i.e., sharp corners). (markup?) #:category graphic #:properties ((thickness 1) - (corner-radius 1) - (font-size 0) - (box-padding 0.5)) + (corner-radius 1) + (font-size 0) + (box-padding 0.5)) "@cindex enclosing text in a box with rounded corners @cindex drawing boxes with rounded corners around text Draw a box with rounded corners around @var{arg}. Looks at @code{thickness}, @@ -686,9 +686,9 @@ Add space around a markup object. Create a box of the same height as the space in the current font." (let ((m (ly:text-interface::interpret-markup layout props " "))) (ly:make-stencil (ly:stencil-expr m) - '(0 . 0) - (ly:stencil-extent m X) - ))) + '(0 . 0) + (ly:stencil-extent m X) + ))) (define-markup-command (hspace layout props amount) (number?) @@ -710,9 +710,9 @@ Create an invisible object taking up horizontal space @var{amount}. (ly:make-stencil "" (cons 0 amount) empty-interval)) (define-markup-command (vspace layout props amount) - (number?) - #:category align - " + (number?) + #:category align + " @cindex creating vertical spaces in text Create an invisible object taking up vertical space @@ -761,11 +761,11 @@ Use a stencil as markup. ((match (regexp-exec bbox-regexp string))) (if match - (map (lambda (x) - (string->number (match:substring match x))) - (cdr (iota 5))) + (map (lambda (x) + (string->number (match:substring match x))) + (cdr (iota 5))) - #f))) + #f))) (define-markup-command (epsfile layout props axis size file-name) (number? number? string?) @@ -820,20 +820,20 @@ rings = \\markup { ;; FIXME (ly:make-stencil (list 'embedded-ps - (format #f " + (format #f " gsave currentpoint translate 0.1 setlinewidth ~a grestore " - str)) + str)) '(0 . 0) '(0 . 0))) (define-markup-command (path layout props thickness commands) (number? list?) #:category graphic #:properties ((line-cap-style 'round) - (line-join-style 'round) - (filled #f)) + (line-join-style 'round) + (filled #f)) " @cindex paths, drawing @cindex drawing paths @@ -888,77 +888,77 @@ samplePath = } @end lilypond" (let* ((half-thickness (/ thickness 2)) - (current-point '(0 . 0)) - (set-point (lambda (lst) (set! current-point lst))) - (relative? (lambda (x) - (string-prefix? "r" (symbol->string (car x))))) - ;; For calculating extents, we want to modify the command - ;; list so that all coordinates are absolute. - (new-commands (map (lambda (x) - (cond - ;; for rmoveto, rlineto - ((and (relative? x) (= 3 (length x))) - (let ((cp (cons - (+ (car current-point) - (second x)) - (+ (cdr current-point) - (third x))))) - (set-point cp) - (list (car cp) - (cdr cp)))) - ;; for rcurveto - ((and (relative? x) (= 7 (length x))) - (let* ((old-cp current-point) - (cp (cons - (+ (car old-cp) - (sixth x)) - (+ (cdr old-cp) - (seventh x))))) - (set-point cp) - (list (+ (car old-cp) (second x)) - (+ (cdr old-cp) (third x)) - (+ (car old-cp) (fourth x)) - (+ (cdr old-cp) (fifth x)) - (car cp) - (cdr cp)))) - ;; for moveto, lineto - ((= 3 (length x)) - (set-point (cons (second x) - (third x))) - (drop x 1)) - ;; for curveto - ((= 7 (length x)) - (set-point (cons (sixth x) - (seventh x))) - (drop x 1)) - ;; keep closepath for filtering; - ;; see `without-closepath'. - (else x))) - commands)) - ;; path-min-max does not accept 0-arg lists, - ;; and since closepath does not affect extents, filter - ;; out those commands here. - (without-closepath (filter (lambda (x) - (not (equal? 'closepath (car x)))) - new-commands)) - (extents (path-min-max - ;; set the origin to the first moveto - (list (list-ref (car without-closepath) 0) - (list-ref (car without-closepath) 1)) - without-closepath)) - (X-extent (cons (list-ref extents 0) (list-ref extents 1))) - (Y-extent (cons (list-ref extents 2) (list-ref extents 3))) - (command-list (fold-right append '() commands))) + (current-point '(0 . 0)) + (set-point (lambda (lst) (set! current-point lst))) + (relative? (lambda (x) + (string-prefix? "r" (symbol->string (car x))))) + ;; For calculating extents, we want to modify the command + ;; list so that all coordinates are absolute. + (new-commands (map (lambda (x) + (cond + ;; for rmoveto, rlineto + ((and (relative? x) (= 3 (length x))) + (let ((cp (cons + (+ (car current-point) + (second x)) + (+ (cdr current-point) + (third x))))) + (set-point cp) + (list (car cp) + (cdr cp)))) + ;; for rcurveto + ((and (relative? x) (= 7 (length x))) + (let* ((old-cp current-point) + (cp (cons + (+ (car old-cp) + (sixth x)) + (+ (cdr old-cp) + (seventh x))))) + (set-point cp) + (list (+ (car old-cp) (second x)) + (+ (cdr old-cp) (third x)) + (+ (car old-cp) (fourth x)) + (+ (cdr old-cp) (fifth x)) + (car cp) + (cdr cp)))) + ;; for moveto, lineto + ((= 3 (length x)) + (set-point (cons (second x) + (third x))) + (drop x 1)) + ;; for curveto + ((= 7 (length x)) + (set-point (cons (sixth x) + (seventh x))) + (drop x 1)) + ;; keep closepath for filtering; + ;; see `without-closepath'. + (else x))) + commands)) + ;; path-min-max does not accept 0-arg lists, + ;; and since closepath does not affect extents, filter + ;; out those commands here. + (without-closepath (filter (lambda (x) + (not (equal? 'closepath (car x)))) + new-commands)) + (extents (path-min-max + ;; set the origin to the first moveto + (list (list-ref (car without-closepath) 0) + (list-ref (car without-closepath) 1)) + without-closepath)) + (X-extent (cons (list-ref extents 0) (list-ref extents 1))) + (Y-extent (cons (list-ref extents 2) (list-ref extents 3))) + (command-list (fold-right append '() commands))) ;; account for line thickness (set! X-extent (interval-widen X-extent half-thickness)) (set! Y-extent (interval-widen Y-extent half-thickness)) (ly:make-stencil - `(path ,thickness `(,@',command-list) - ',line-cap-style ',line-join-style ,filled) - X-extent - Y-extent))) + `(path ,thickness `(,@',command-list) + ',line-cap-style ',line-join-style ,filled) + X-extent + Y-extent))) (define-markup-list-command (score-lines layout props score) (ly:score?) @@ -981,8 +981,8 @@ be split across pages." (- (car (paper-system-staff-extents paper-system))) Y)) (vector->list (ly:paper-score-paper-systems output))) - (begin - (ly:warning (_"no systems found in \\score markup, does it have a \\layout block?")) + (begin + (ly:warning (_"no systems found in \\score markup, does it have a \\layout block?")) '())))) (define-markup-command (score layout props score) @@ -1099,12 +1099,12 @@ Like simple-markup, but use tie characters for @q{~} tilde symbols. (define (replace-ties tie str) (if (string-contains str "~") (let* - ((half-space (/ word-space 2)) - (parts (string-split str #\~)) - (tie-str (markup #:hspace half-space - #:musicglyph tie - #:hspace half-space)) - (joined (list-join parts tie-str))) + ((half-space (/ word-space 2)) + (parts (string-split str #\~)) + (tie-str (markup #:hspace half-space + #:musicglyph tie + #:hspace half-space)) + (joined (list-join parts tie-str))) (make-concat-markup joined)) str)) @@ -1115,16 +1115,16 @@ Like simple-markup, but use tie characters for @q{~} tilde symbols. (let ((match (match-short str))) (if (not match) (make-concat-markup (list - mkp - (replace-ties "ties.lyric.default" str))) + mkp + (replace-ties "ties.lyric.default" str))) (let ((new-str (match:suffix match)) (new-mkp (make-concat-markup (list - mkp - (replace-ties "ties.lyric.default" - (match:prefix match)) - (replace-ties "ties.lyric.short" - (match:substring match)))))) - (replace-short new-str new-mkp))))) + mkp + (replace-ties "ties.lyric.default" + (match:prefix match)) + (replace-ties "ties.lyric.short" + (match:substring match)))))) + (replace-short new-str new-mkp))))) (interpret-markup layout props @@ -1151,12 +1151,12 @@ Like simple-markup, but use tie characters for @q{~} tilde symbols. ((= (length text-widths) word-count) (cons (- (- (/ line-width (1- word-count)) (car text-widths)) - (/ (car (cdr text-widths)) 2)) + (/ (car (cdr text-widths)) 2)) (get-fill-space word-count line-width word-space (cdr text-widths)))) ;; special case last padding ((= (length text-widths) 2) (list (- (/ line-width (1- word-count)) - (+ (/ (car text-widths) 2) (car (cdr text-widths)))) 0)) + (+ (/ (car text-widths) 2) (car (cdr text-widths)))) 0)) (else (let ((default-padding (- (/ line-width (1- word-count)) @@ -1252,7 +1252,7 @@ If there are no arguments, return an empty stencil. (markup-list?) #:category align #:properties ((word-space) - (text-direction RIGHT)) + (text-direction RIGHT)) "Put @var{args} in a horizontal line. The property @code{word-space} determines the space between markups in @var{args}. @@ -1293,12 +1293,12 @@ equivalent to @code{\"fi\"}. (fold-right (lambda (arg result-list) (let ((result (if (pair? result-list) (car result-list) - '()))) + '()))) (if (and (pair? arg) (eqv? (car arg) simple-markup)) - (set! arg (cadr arg))) + (set! arg (cadr arg))) (if (and (string? result) (string? arg)) (cons (string-append arg result) (cdr result-list)) - (cons arg result-list)))) + (cons arg result-list)))) '() arg-list)) @@ -1313,12 +1313,12 @@ equivalent to @code{\"fi\"}. (concat-string-args args)))))) (define (wordwrap-stencils stencils - justify base-space line-width text-dir) + justify base-space line-width text-dir) "Perform simple wordwrap, return stencil of each line." (define space (if justify ;; justify only stretches lines. - (* 0.7 base-space) - base-space)) + (* 0.7 base-space) + base-space)) (define (stencil-space stencil line-start) (if (ly:stencil-empty? stencil X) 0 @@ -1329,17 +1329,17 @@ equivalent to @code{\"fi\"}. X RIGHT stencil) X)))) (define (take-list width space stencils - accumulator accumulated-width) + accumulator accumulated-width) "Return (head-list . tail) pair, with head-list fitting into width" (if (null? stencils) - (cons accumulator stencils) - (let* ((first (car stencils)) + (cons accumulator stencils) + (let* ((first (car stencils)) (first-wid (stencil-space first (null? accumulator))) (newwid (+ (if (or (ly:stencil-empty? first Y) (ly:stencil-empty? first X)) 0 space) first-wid accumulated-width))) - (if (or (null? accumulator) + (if (or (null? accumulator) (< newwid width)) (take-list width space (cdr stencils) @@ -1350,15 +1350,15 @@ equivalent to @code{\"fi\"}. (todo stencils)) (let* ((line-break (take-list line-width space todo '() 0.0)) - (line-stencils (car line-break)) - (space-left (- line-width + (line-stencils (car line-break)) + (space-left (- line-width (stencil-space (stack-stencil-line 0 line-stencils) #t))) (line-words (count (lambda (s) (not (or (ly:stencil-empty? s Y) (ly:stencil-empty? s X)))) line-stencils)) - (line-word-space (cond ((not justify) space) + (line-word-space (cond ((not justify) space) ;; don't stretch last line of paragraph. ;; hmmm . bug - will overstretch the last line in some case. ((null? (cdr line-break)) @@ -1384,8 +1384,8 @@ equivalent to @code{\"fi\"}. (define-markup-list-command (wordwrap-internal layout props justify args) (boolean? markup-list?) #:properties ((line-width #f) - (word-space) - (text-direction RIGHT)) + (word-space) + (text-direction RIGHT)) "Internal markup list command used to define @code{\\justify} and @code{\\wordwrap}." (wordwrap-stencils (interpret-markup-list layout props args) justify @@ -1398,7 +1398,7 @@ equivalent to @code{\"fi\"}. (markup-list?) #:category align #:properties ((baseline-skip) - wordwrap-internal-markup-list) + wordwrap-internal-markup-list) " @cindex justifying text @@ -1423,7 +1423,7 @@ Use @code{\\override #'(line-width . @var{X})} to set the line width; (markup-list?) #:category align #:properties ((baseline-skip) - wordwrap-internal-markup-list) + wordwrap-internal-markup-list) "Simple wordwrap. Use @code{\\override #'(line-width . @var{X})} to set the line width, where @var{X} is the number of staff spaces. @@ -1438,13 +1438,13 @@ the line width, where @var{X} is the number of staff spaces. } @end lilypond" (stack-lines DOWN 0.0 baseline-skip - (wordwrap-internal-markup-list layout props #f args))) + (wordwrap-internal-markup-list layout props #f args))) (define-markup-list-command (wordwrap-string-internal layout props justify arg) (boolean? string?) #:properties ((line-width) - (word-space) - (text-direction RIGHT)) + (word-space) + (text-direction RIGHT)) "Internal markup list command used to define @code{\\justify-string} and @code{\\wordwrap-string}." (let* ((para-strings (regexp-split @@ -1470,7 +1470,7 @@ the line width, where @var{X} is the number of staff spaces. (string?) #:category align #:properties ((baseline-skip) - wordwrap-string-internal-markup-list) + wordwrap-string-internal-markup-list) "Wordwrap a string. Paragraphs may be separated with double newlines. @lilypond[verbatim,quote] @@ -1496,7 +1496,7 @@ the line width, where @var{X} is the number of staff spaces. (string?) #:category align #:properties ((baseline-skip) - wordwrap-string-internal-markup-list) + wordwrap-string-internal-markup-list) "Justify a string. Paragraphs may be separated with double newlines @lilypond[verbatim,quote] @@ -1610,7 +1610,7 @@ curly braces as an argument; the follow example will not compile: } @end lilypond" (let* ((s1 (interpret-markup layout props arg1)) - (s2 (interpret-markup layout props arg2))) + (s2 (interpret-markup layout props arg2))) (ly:stencil-add s1 s2))) ;; @@ -1643,7 +1643,7 @@ in @var{args}. (markup-list?) #:category align #:properties ((direction) - (baseline-skip)) + (baseline-skip)) " @cindex changing direction of text columns @@ -1706,7 +1706,7 @@ Put @code{args} in a centered column. (markup-list?) #:category align #:properties ((baseline-skip)) - " + " @cindex text columns, left-aligned Put @code{args} in a left-aligned column. @@ -1726,7 +1726,7 @@ Put @code{args} in a left-aligned column. (markup-list?) #:category align #:properties ((baseline-skip)) - " + " @cindex text columns, right-aligned Put @code{args} in a right-aligned column. @@ -2091,8 +2091,8 @@ returns an empty markup. @var{procedure} should take a single argument." (let ((anonymous-with-signature (lambda (layout props arg) (procedure layout props arg)))) (set-object-property! anonymous-with-signature - 'markup-signature - (list markup?)) + 'markup-signature + (list markup?)) (interpret-markup layout props (list anonymous-with-signature arg)))) (define-markup-command (footnote layout props mkup note) @@ -2109,14 +2109,14 @@ returns an empty markup. @end lilypond The footnote will not be annotated automatically." (ly:stencil-combine-at-edge - (interpret-markup layout props mkup) - X - RIGHT - (ly:make-stencil - `(footnote (gensym "footnote") #f ,(interpret-markup layout props note)) - '(0 . 0) - '(0 . 0)) - 0.0)) + (interpret-markup layout props mkup) + X + RIGHT + (ly:make-stencil + `(footnote (gensym "footnote") #f ,(interpret-markup layout props note)) + '(0 . 0) + '(0 . 0)) + 0.0)) (define-markup-command (auto-footnote layout props mkup note) (markup? markup?) @@ -2137,49 +2137,49 @@ The footnote will be annotated automatically." (footnote-hash (gensym "footnote")) (stencil-seed 0) (gauge-stencil (interpret-markup + layout + props + ((ly:output-def-lookup layout - props - ((ly:output-def-lookup - layout - 'footnote-numbering-function) - stencil-seed))) + 'footnote-numbering-function) + stencil-seed))) (x-ext (ly:stencil-extent gauge-stencil X)) - (y-ext (ly:stencil-extent gauge-stencil Y)) + (y-ext (ly:stencil-extent gauge-stencil Y)) (footnote-number - `(delay-stencil-evaluation - ,(delay - (ly:stencil-expr - (let* ((table - (ly:output-def-lookup layout - 'number-footnote-table)) - (footnote-stencil (if (list? table) - (assoc-get footnote-hash - table) - empty-stencil)) - (footnote-stencil (if (ly:stencil? footnote-stencil) - footnote-stencil - (begin - (ly:programming-error -"Cannot find correct footnote for a markup object.") - empty-stencil))) - (gap (- (interval-length x-ext) - (interval-length - (ly:stencil-extent footnote-stencil X)))) - (y-trans (- (+ (cdr y-ext) - raise) - (cdr (ly:stencil-extent footnote-stencil - Y))))) - (ly:stencil-translate footnote-stencil - (cons gap y-trans))))))) + `(delay-stencil-evaluation + ,(delay + (ly:stencil-expr + (let* ((table + (ly:output-def-lookup layout + 'number-footnote-table)) + (footnote-stencil (if (list? table) + (assoc-get footnote-hash + table) + empty-stencil)) + (footnote-stencil (if (ly:stencil? footnote-stencil) + footnote-stencil + (begin + (ly:programming-error + "Cannot find correct footnote for a markup object.") + empty-stencil))) + (gap (- (interval-length x-ext) + (interval-length + (ly:stencil-extent footnote-stencil X)))) + (y-trans (- (+ (cdr y-ext) + raise) + (cdr (ly:stencil-extent footnote-stencil + Y))))) + (ly:stencil-translate footnote-stencil + (cons gap y-trans))))))) (main-stencil (ly:stencil-combine-at-edge - markup-stencil - X - RIGHT - (ly:make-stencil footnote-number x-ext y-ext) - padding))) - (ly:stencil-add - main-stencil - (ly:make-stencil + markup-stencil + X + RIGHT + (ly:make-stencil footnote-number x-ext y-ext) + padding))) + (ly:stencil-add + main-stencil + (ly:make-stencil `(footnote ,footnote-hash #t ,(interpret-markup layout props note)) '(0 . 0) '(0 . 0))))) @@ -2260,7 +2260,7 @@ may be any property supported by @rinternals{font-interface}, } @end lilypond" (interpret-markup layout props - `(,fontsize-markup -1 ,arg))) + `(,fontsize-markup -1 ,arg))) (define-markup-command (larger layout props arg) (markup?) @@ -2276,7 +2276,7 @@ may be any property supported by @rinternals{font-interface}, } @end lilypond" (interpret-markup layout props - `(,fontsize-markup 1 ,arg))) + `(,fontsize-markup 1 ,arg))) (define-markup-command (finger layout props arg) (markup?) @@ -2314,21 +2314,21 @@ Adjusts @code{baseline-skip} and @code{word-space} accordingly. (ref-word-space (chain-assoc-get 'word-space text-props 0.6)) (ref-baseline (chain-assoc-get 'baseline-skip text-props 3)) (magnification (/ size ref-size))) - (interpret-markup - layout - (cons - `((baseline-skip . ,(* magnification ref-baseline)) - (word-space . ,(* magnification ref-word-space)) - (font-size . ,(magnification->font-size magnification))) - props) - arg))) + (interpret-markup + layout + (cons + `((baseline-skip . ,(* magnification ref-baseline)) + (word-space . ,(* magnification ref-word-space)) + (font-size . ,(magnification->font-size magnification))) + props) + arg))) (define-markup-command (fontsize layout props increment arg) (number? markup?) #:category font #:properties ((font-size 0) - (word-space 1) - (baseline-skip 2)) + (word-space 1) + (baseline-skip 2)) "Add @var{increment} to the font-size. Adjusts @code{baseline-skip} accordingly. @@ -2570,33 +2570,33 @@ Note: @code{\\smallCaps} does not support accented characters. (define (char-list->markup chars lower) (let ((final-string (string-upcase (reverse-list->string chars)))) (if lower - (markup #:fontsize -2 final-string) - final-string))) + (markup #:fontsize -2 final-string) + final-string))) (define (make-small-caps rest-chars currents current-is-lower prev-result) (if (null? rest-chars) - (make-concat-markup - (reverse! (cons (char-list->markup currents current-is-lower) - prev-result))) - (let* ((ch (car rest-chars)) - (is-lower (char-lower-case? ch))) - (if (or (and current-is-lower is-lower) - (and (not current-is-lower) (not is-lower))) - (make-small-caps (cdr rest-chars) - (cons ch currents) - is-lower - prev-result) - (make-small-caps (cdr rest-chars) - (list ch) - is-lower - (if (null? currents) - prev-result - (cons (char-list->markup - currents current-is-lower) - prev-result))))))) + (make-concat-markup + (reverse! (cons (char-list->markup currents current-is-lower) + prev-result))) + (let* ((ch (car rest-chars)) + (is-lower (char-lower-case? ch))) + (if (or (and current-is-lower is-lower) + (and (not current-is-lower) (not is-lower))) + (make-small-caps (cdr rest-chars) + (cons ch currents) + is-lower + prev-result) + (make-small-caps (cdr rest-chars) + (list ch) + is-lower + (if (null? currents) + prev-result + (cons (char-list->markup + currents current-is-lower) + prev-result))))))) (interpret-markup layout props - (if (string? arg) - (make-small-caps (string->list arg) (list) #f (list)) - arg))) + (if (string? arg) + (make-small-caps (string->list arg) (list) #f (list)) + arg))) (define-markup-command (caps layout props arg) (markup?) @@ -2650,7 +2650,7 @@ done in a different font. The recommended font for this is bold and italic. ;; ugh - latin1 (interpret-markup layout (prepend-alist-chain 'font-encoding 'latin1 props) - arg)) + arg)) (define-markup-command (italic layout props arg) (markup?) @@ -2724,7 +2724,7 @@ of @code{italic}. } @end lilypond" (interpret-markup layout (prepend-alist-chain 'font-series 'medium props) - arg)) + arg)) (define-markup-command (normal-text layout props arg) (markup?) @@ -2748,8 +2748,8 @@ normal text font, no matter what font was used earlier. ;; ugh - latin1 (interpret-markup layout (cons '((font-family . roman) (font-shape . upright) - (font-series . medium) (font-encoding . latin1)) - props) + (font-series . medium) (font-encoding . latin1)) + props) arg)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -2772,13 +2772,13 @@ the possible glyphs. } @end lilypond" (let* ((font (ly:paper-get-font layout - (cons '((font-encoding . fetaMusic) - (font-name . #f)) + (cons '((font-encoding . fetaMusic) + (font-name . #f)) - props))) - (glyph (ly:font-get-glyph font glyph-name))) + props))) + (glyph (ly:font-get-glyph font glyph-name))) (if (null? (ly:stencil-expr glyph)) - (ly:warning (_ "Cannot find glyph ~a") glyph-name)) + (ly:warning (_ "Cannot find glyph ~a") glyph-name)) glyph)) @@ -2912,8 +2912,8 @@ Draw @var{arg} in color specified by @var{color}. @end lilypond" (let ((stil (interpret-markup layout props arg))) (ly:make-stencil (list 'color color (ly:stencil-expr stil)) - (ly:stencil-extent stil X) - (ly:stencil-extent stil Y)))) + (ly:stencil-extent stil X) + (ly:stencil-extent stil Y)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; glyphs @@ -2939,14 +2939,14 @@ Use the filled head if @var{filled} is specified. @end lilypond" (let* ((name (format #f "arrowheads.~a.~a~a" - (if filled - "close" - "open") - axis - dir))) + (if filled + "close" + "open") + axis + dir))) (ly:font-get-glyph (ly:paper-get-font layout (cons '((font-encoding . fetaMusic)) - props)) + props)) name))) (define-markup-command (lookup layout props glyph-name) @@ -2965,7 +2965,7 @@ Use the filled head if @var{filled} is specified. } @end lilypond" (ly:font-get-glyph (ly:paper-get-font layout props) - glyph-name)) + glyph-name)) (define-markup-command (char layout props num) (integer?) @@ -2991,16 +2991,16 @@ format require the prefix @code{#x}. (integer->char (+ i (char->integer #\A))))) (define number->mark-alphabet-vector (list->vector - (map (lambda (i) (integer->char (+ i (char->integer #\A)))) (iota 26)))) + (map (lambda (i) (integer->char (+ i (char->integer #\A)))) (iota 26)))) (define (number->markletter-string vec n) "Double letters for big marks." (let* ((lst (vector-length vec))) (if (>= n lst) - (string-append (number->markletter-string vec (1- (quotient n lst))) - (number->markletter-string vec (remainder n lst))) - (make-string 1 (vector-ref vec n))))) + (string-append (number->markletter-string vec (1- (quotient n lst))) + (number->markletter-string vec (remainder n lst))) + (make-string 1 (vector-ref vec n))))) (define-markup-command (markletter layout props num) (integer?) @@ -3010,10 +3010,10 @@ format require the prefix @code{#x}. @lilypond[verbatim,quote] \\markup { - \\markletter #8 - \\hspace #2 - \\markletter #26 -} + \\markletter #8 + \\hspace #2 + \\markletter #26 + } @end lilypond" (ly:text-interface::interpret-markup layout props (number->markletter-string number->mark-letter-vector num))) @@ -3021,7 +3021,7 @@ format require the prefix @code{#x}. (define-markup-command (markalphabet layout props num) (integer?) #:category other - "Make a markup letter for @var{num}. The letters start with A to@tie{}Z + "Make a markup letter for @var{num}. The letters start with A to@tie{}Z and continue with double letters. @lilypond[verbatim,quote] @@ -3031,67 +3031,67 @@ and continue with double letters. \\markalphabet #26 } @end lilypond" - (ly:text-interface::interpret-markup layout props - (number->markletter-string number->mark-alphabet-vector num))) + (ly:text-interface::interpret-markup layout props + (number->markletter-string number->mark-alphabet-vector num))) (define-public (horizontal-slash-interval num forward number-interval mag) (if forward - (cond ;((= num 6) (interval-widen number-interval (* mag 0.5))) - ;((= num 5) (interval-widen number-interval (* mag 0.5))) - (else (interval-widen number-interval (* mag 0.25)))) - (cond ((= num 6) (interval-widen number-interval (* mag 0.5))) - ;((= num 5) (interval-widen number-interval (* mag 0.5))) - (else (interval-widen number-interval (* mag 0.25)))) - )) + (cond ;((= num 6) (interval-widen number-interval (* mag 0.5))) + ;((= num 5) (interval-widen number-interval (* mag 0.5))) + (else (interval-widen number-interval (* mag 0.25)))) + (cond ((= num 6) (interval-widen number-interval (* mag 0.5))) + ;((= num 5) (interval-widen number-interval (* mag 0.5))) + (else (interval-widen number-interval (* mag 0.25)))) + )) (define-public (adjust-slash-stencil num forward stencil mag) (if forward - (cond ((= num 2) - (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2)))) - ((= num 3) - (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2)))) - ;((= num 5) - ;(ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.07)))) - ;((= num 7) - ; (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15)))) - (else stencil)) - (cond ((= num 6) - (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.15)))) - ;((= num 8) - ; (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15)))) - (else stencil)) + (cond ((= num 2) + (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2)))) + ((= num 3) + (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2)))) + ;((= num 5) + ;(ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.07)))) + ;((= num 7) + ; (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15)))) + (else stencil)) + (cond ((= num 6) + (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.15)))) + ;((= num 8) + ; (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15)))) + (else stencil)) + ) ) -) (define (slashed-digit-internal layout props num forward font-size thickness) (let* ((mag (magstep font-size)) (thickness (* mag (ly:output-def-lookup layout 'line-thickness) thickness)) - ; backward slashes might use slope and point in the other direction! + ; backward slashes might use slope and point in the other direction! (dy (* mag (if forward 0.4 -0.4))) (number-stencil (interpret-markup layout (prepend-alist-chain 'font-encoding 'fetaText props) (number->string num))) (num-x (horizontal-slash-interval num forward (ly:stencil-extent number-stencil X) mag)) (center (interval-center (ly:stencil-extent number-stencil Y))) - ; Use the real extents of the slash, not the whole number, because we - ; might translate the slash later on! + ; Use the real extents of the slash, not the whole number, because we + ; might translate the slash later on! (num-y (interval-widen (cons center center) (abs dy))) (is-sane (and (interval-sane? num-x) (interval-sane? num-y))) (slash-stencil (if is-sane (make-line-stencil thickness - (car num-x) (- (interval-center num-y) dy) - (cdr num-x) (+ (interval-center num-y) dy)) + (car num-x) (- (interval-center num-y) dy) + (cdr num-x) (+ (interval-center num-y) dy)) #f))) (if (ly:stencil? slash-stencil) - (begin - ; for some numbers we need to shift the slash/backslash up or down to make - ; the slashed digit look better - (set! slash-stencil (adjust-slash-stencil num forward slash-stencil mag)) - (set! number-stencil - (ly:stencil-add number-stencil slash-stencil))) - (ly:warning "Unable to create slashed digit ~a" num)) + (begin + ; for some numbers we need to shift the slash/backslash up or down to make + ; the slashed digit look better + (set! slash-stencil (adjust-slash-stencil num forward slash-stencil mag)) + (set! number-stencil + (ly:stencil-add number-stencil slash-stencil))) + (ly:warning "Unable to create slashed digit ~a" num)) number-stencil)) @@ -3099,7 +3099,7 @@ and continue with double letters. (integer?) #:category other #:properties ((font-size 0) - (thickness 1.6)) + (thickness 1.6)) " @cindex slashed digits @@ -3119,7 +3119,7 @@ figured bass notation. (integer?) #:category other #:properties ((font-size 0) - (thickness 1.6)) + (thickness 1.6)) " @cindex backslashed digits @@ -3167,8 +3167,8 @@ figured bass notation. \\markup { \\eyeglasses } @end lilypond" (interpret-markup layout props - (make-override-markup '(line-cap-style . butt) - (make-path-markup 0.15 eyeglassespath)))) + (make-override-markup '(line-cap-style . butt) + (make-path-markup 0.15 eyeglassespath)))) (define-markup-command (left-brace layout props size) (number?) @@ -3187,28 +3187,28 @@ A feta brace in point size @var{size}. (cons '((font-encoding . fetaBraces) (font-name . #f)) props))) - (glyph-count (1- (ly:otf-glyph-count font))) + (glyph-count (1- (ly:otf-glyph-count font))) (scale (ly:output-def-lookup layout 'output-scale)) (scaled-size (/ (ly:pt size) scale)) (glyph (lambda (n) (ly:font-get-glyph font (string-append "brace" - (number->string n))))) - (get-y-from-brace (lambda (brace) - (interval-length - (ly:stencil-extent (glyph brace) Y)))) + (number->string n))))) + (get-y-from-brace (lambda (brace) + (interval-length + (ly:stencil-extent (glyph brace) Y)))) (find-brace (binary-search 0 glyph-count get-y-from-brace scaled-size)) (glyph-found (glyph find-brace))) (if (or (null? (ly:stencil-expr glyph-found)) - (< scaled-size (interval-length (ly:stencil-extent (glyph 0) Y))) - (> scaled-size (interval-length - (ly:stencil-extent (glyph glyph-count) Y)))) + (< scaled-size (interval-length (ly:stencil-extent (glyph 0) Y))) + (> scaled-size (interval-length + (ly:stencil-extent (glyph glyph-count) Y)))) (begin (ly:warning (_ "no brace found for point size ~S ") size) (ly:warning (_ "defaulting to ~S pt") - (/ (* scale (interval-length - (ly:stencil-extent glyph-found Y))) - (ly:pt 1))))) + (/ (* scale (interval-length + (ly:stencil-extent glyph-found Y))) + (ly:pt 1))))) glyph-found)) (define-markup-command (right-brace layout props size) @@ -3256,94 +3256,94 @@ Supported flag-styles are @code{default}, @code{old-straight-flag} and @end lilypond" (define (get-glyph-name-candidates dir log style) (map (lambda (dir-name) - (format #f "noteheads.~a~a" dir-name - (if (and (symbol? style) - (not (equal? 'default style))) - (select-head-glyph style (min log 2)) - (min log 2)))) - (list (if (= dir UP) "u" "d") - "s"))) + (format #f "noteheads.~a~a" dir-name + (if (and (symbol? style) + (not (equal? 'default style))) + (select-head-glyph style (min log 2)) + (min log 2)))) + (list (if (= dir UP) "u" "d") + "s"))) (define (get-glyph-name font cands) (if (null? cands) - "" - (if (ly:stencil-empty? (ly:font-get-glyph font (car cands))) - (get-glyph-name font (cdr cands)) - (car cands)))) + "" + (if (ly:stencil-empty? (ly:font-get-glyph font (car cands))) + (get-glyph-name font (cdr cands)) + (car cands)))) (define (buildflags flag-stencil remain curr-stencil spacing) - ;; Function to recursively create a stencil with @code{remain} flags - ;; from the single-flag stencil @code{curr-stencil}, which is already - ;; translated to the position of the previous flag position. - ;; - ;; Copy and paste from /scm/flag-styles.scm + ;; Function to recursively create a stencil with @code{remain} flags + ;; from the single-flag stencil @code{curr-stencil}, which is already + ;; translated to the position of the previous flag position. + ;; + ;; Copy and paste from /scm/flag-styles.scm (if (> remain 0) (let* ((translated-stencil - (ly:stencil-translate-axis curr-stencil spacing Y)) + (ly:stencil-translate-axis curr-stencil spacing Y)) (new-stencil (ly:stencil-add flag-stencil translated-stencil))) (buildflags new-stencil (- remain 1) translated-stencil spacing)) flag-stencil)) (define (straight-flag-mrkp flag-thickness flag-spacing - upflag-angle upflag-length - downflag-angle downflag-length - dir) - ;; Create a stencil for a straight flag. @var{flag-thickness} and - ;; @var{flag-spacing} are given in staff spaces, @var{upflag-angle} and - ;; @var{downflag-angle} are given in degrees, and @var{upflag-length} and - ;; @var{downflag-length} are given in staff spaces. - ;; - ;; All lengths are scaled according to the font size of the note. - ;; - ;; From /scm/flag-styles.scm, modified to fit here. - - (let* ((stem-up (> dir 0)) - ; scale with the note size - (factor (magstep font-size)) - (stem-thickness (* factor 0.1)) - (line-thickness (ly:output-def-lookup layout 'line-thickness)) - (half-stem-thickness (/ (* stem-thickness line-thickness) 2)) - (raw-length (if stem-up upflag-length downflag-length)) - (angle (if stem-up upflag-angle downflag-angle)) - (flag-length (+ (* raw-length factor) half-stem-thickness)) - (flag-end (polar->rectangular flag-length angle)) - (thickness (* flag-thickness factor)) - (thickness-offset (cons 0 (* -1 thickness dir))) - (spacing (* -1 flag-spacing factor dir)) - (start (cons (- half-stem-thickness) (* half-stem-thickness dir))) - ; The points of a round-filled-polygon need to be given in - ; clockwise order, otherwise the polygon will be enlarged by - ; blot-size*2! - (points (if stem-up (list start flag-end - (offset-add flag-end thickness-offset) - (offset-add start thickness-offset)) - (list start - (offset-add start thickness-offset) - (offset-add flag-end thickness-offset) - flag-end))) - (stencil (ly:round-filled-polygon points half-stem-thickness)) - ; Log for 1/8 is 3, so we need to subtract 3 - (flag-stencil (buildflags stencil (- log 3) stencil spacing))) - flag-stencil)) + upflag-angle upflag-length + downflag-angle downflag-length + dir) + ;; Create a stencil for a straight flag. @var{flag-thickness} and + ;; @var{flag-spacing} are given in staff spaces, @var{upflag-angle} and + ;; @var{downflag-angle} are given in degrees, and @var{upflag-length} and + ;; @var{downflag-length} are given in staff spaces. + ;; + ;; All lengths are scaled according to the font size of the note. + ;; + ;; From /scm/flag-styles.scm, modified to fit here. + + (let* ((stem-up (> dir 0)) + ; scale with the note size + (factor (magstep font-size)) + (stem-thickness (* factor 0.1)) + (line-thickness (ly:output-def-lookup layout 'line-thickness)) + (half-stem-thickness (/ (* stem-thickness line-thickness) 2)) + (raw-length (if stem-up upflag-length downflag-length)) + (angle (if stem-up upflag-angle downflag-angle)) + (flag-length (+ (* raw-length factor) half-stem-thickness)) + (flag-end (polar->rectangular flag-length angle)) + (thickness (* flag-thickness factor)) + (thickness-offset (cons 0 (* -1 thickness dir))) + (spacing (* -1 flag-spacing factor dir)) + (start (cons (- half-stem-thickness) (* half-stem-thickness dir))) + ; The points of a round-filled-polygon need to be given in + ; clockwise order, otherwise the polygon will be enlarged by + ; blot-size*2! + (points (if stem-up (list start flag-end + (offset-add flag-end thickness-offset) + (offset-add start thickness-offset)) + (list start + (offset-add start thickness-offset) + (offset-add flag-end thickness-offset) + flag-end))) + (stencil (ly:round-filled-polygon points half-stem-thickness)) + ; Log for 1/8 is 3, so we need to subtract 3 + (flag-stencil (buildflags stencil (- log 3) stencil spacing))) + flag-stencil)) (let* ((font (ly:paper-get-font layout (cons '((font-encoding . fetaMusic)) - props))) + props))) (size-factor (magstep font-size)) (blot (ly:output-def-lookup layout 'blot-diameter)) (head-glyph-name - (let ((result (get-glyph-name font - (get-glyph-name-candidates - (sign dir) log style)))) - (if (string-null? result) - ;; If no glyph name can be found, select default heads. - ;; Though this usually means an unsupported style has been - ;; chosen, it also prevents unrelated 'style settings from - ;; other grobs (e.g., TextSpanner and TimeSignature) leaking - ;; into markup. - (get-glyph-name font - (get-glyph-name-candidates - (sign dir) log 'default)) - result))) + (let ((result (get-glyph-name font + (get-glyph-name-candidates + (sign dir) log style)))) + (if (string-null? result) + ;; If no glyph name can be found, select default heads. + ;; Though this usually means an unsupported style has been + ;; chosen, it also prevents unrelated 'style settings from + ;; other grobs (e.g., TextSpanner and TimeSignature) leaking + ;; into markup. + (get-glyph-name font + (get-glyph-name-candidates + (sign dir) log 'default)) + result))) (head-glyph (ly:font-get-glyph font head-glyph-name)) (ancient-flags? (or (eq? style 'mensural) (eq? style 'neomensural))) (attach-indices (ly:note-head::stem-attachment font head-glyph-name)) @@ -3352,9 +3352,9 @@ Supported flag-styles are @code{default}, @code{old-straight-flag} and (stem-thickness (* size-factor (if ancient-flags? 0.1 0.13))) (stemy (* dir stem-length)) (attach-off (cons (interval-index - (ly:stencil-extent head-glyph X) - (* (sign dir) (car attach-indices))) - ; fixme, this is inconsistent between X & Y. + (ly:stencil-extent head-glyph X) + (* (sign dir) (car attach-indices))) + ; fixme, this is inconsistent between X & Y. (* (sign dir) (interval-index (ly:stencil-extent head-glyph Y) @@ -3364,12 +3364,12 @@ Supported flag-styles are @code{default}, @code{old-straight-flag} and (stem-X-corr (if ancient-flags? (* 0.5 dir stem-thickness) 0)) (stem-glyph (and (> log 0) (ly:round-filled-box - (ordered-cons (+ stem-X-corr (car attach-off)) - (+ stem-X-corr (car attach-off) - (* (- (sign dir)) stem-thickness))) - (cons (min stemy (cdr attach-off)) - (max stemy (cdr attach-off))) - (/ stem-thickness 3)))) + (ordered-cons (+ stem-X-corr (car attach-off)) + (+ stem-X-corr (car attach-off) + (* (- (sign dir)) stem-thickness))) + (cons (min stemy (cdr attach-off)) + (max stemy (cdr attach-off))) + (/ stem-thickness 3)))) (dot (ly:font-get-glyph font "dots.dot")) (dotwid (interval-length (ly:stencil-extent dot X))) (dots (and (> dot-count 0) @@ -3389,34 +3389,34 @@ Supported flag-styles are @code{default}, @code{old-straight-flag} and 0)) (flaggl (and (> log 2) (ly:stencil-translate - (cond ((eq? flag-style 'modern-straight-flag) - modern-straight-flag) - ((eq? flag-style 'old-straight-flag) - old-straight-flag) - (else - (ly:font-get-glyph font - (format #f (if ancient-flags? - "flags.mensural~a2~a" - "flags.~a~a") - (if (> dir 0) "u" "d") - log)))) - (cons (+ (car attach-off) - ;; For tighter stems (with ancient-flags) the - ;; flag has to be adjusted different. - (if (and (not ancient-flags?) (< dir 0)) - stem-thickness - 0)) - (+ stemy flag-style-Y-corr)))))) + (cond ((eq? flag-style 'modern-straight-flag) + modern-straight-flag) + ((eq? flag-style 'old-straight-flag) + old-straight-flag) + (else + (ly:font-get-glyph font + (format #f (if ancient-flags? + "flags.mensural~a2~a" + "flags.~a~a") + (if (> dir 0) "u" "d") + log)))) + (cons (+ (car attach-off) + ;; For tighter stems (with ancient-flags) the + ;; flag has to be adjusted different. + (if (and (not ancient-flags?) (< dir 0)) + stem-thickness + 0)) + (+ stemy flag-style-Y-corr)))))) ;; If there is a flag on an upstem and the stem is short, move the dots ;; to avoid the flag. 16th notes get a special case because their flags ;; hang lower than any other flags. ;; Not with ancient flags or straight-flags. (if (and dots (> dir 0) (> log 2) - (or (eq? flag-style 'default) (null? flag-style)) - (not ancient-flags?) - (or (< dir 1.15) (and (= log 4) (< dir 1.3)))) - (set! dots (ly:stencil-translate-axis dots 0.5 X))) + (or (eq? flag-style 'default) (null? flag-style)) + (not ancient-flags?) + (or (< dir 1.15) (and (= log 4) (< dir 1.3)))) + (set! dots (ly:stencil-translate-axis dots 0.5 X))) (if flaggl (set! stem-glyph (ly:stencil-add flaggl stem-glyph))) (if (ly:stencil? stem-glyph) @@ -3425,11 +3425,11 @@ Supported flag-styles are @code{default}, @code{old-straight-flag} and (if (ly:stencil? dots) (set! stem-glyph (ly:stencil-add - (ly:stencil-translate-axis - dots - (+ (cdr (ly:stencil-extent head-glyph X)) dotwid) - X) - stem-glyph))) + (ly:stencil-translate-axis + dots + (+ (cdr (ly:stencil-extent head-glyph X)) dotwid) + X) + stem-glyph))) stem-glyph)) (define-public log2 @@ -3506,44 +3506,44 @@ A rest or multi-measure-rest symbol. ;; If no glyph exists, select others for the specified styles ;; otherwise defaulting. (style-strg - (cond ( + (cond ( ;; 'baroque needs to be special-cased, otherwise ;; `select-head-glyph´ would catch neomensural-glyphs for ;; this style, if (< log 0). (eq? style 'baroque) - (string-append (number->string log) "")) - ((eq? style 'petrucci) - (string-append (number->string log) "mensural")) - ;; In other cases `select-head-glyph´ from output-lib.scm - ;; works for rest-glyphs, too. - ((and (symbol? style) (not (eq? style 'default))) - (select-head-glyph style log)) - (else log))) + (string-append (number->string log) "")) + ((eq? style 'petrucci) + (string-append (number->string log) "mensural")) + ;; In other cases `select-head-glyph´ from output-lib.scm + ;; works for rest-glyphs, too. + ((and (symbol? style) (not (eq? style 'default))) + (select-head-glyph style log)) + (else log))) ;; Choose ledgered glyphs for whole and half rest. ;; Except for the specified styles, logs and MultiMeasureRests. (ledger-style-rests - (if (and (or (list? style) - (not (member style - '(neomensural mensural petrucci)))) - (not multi-measure-rest) - (or (= log 0) (= log 1))) + (if (and (or (list? style) + (not (member style + '(neomensural mensural petrucci)))) + (not multi-measure-rest) + (or (= log 0) (= log 1))) "o" ""))) (format #f "rests.~a~a" style-strg ledger-style-rests))) (define (get-glyph-name font cands) - (if (ly:stencil-empty? (ly:font-get-glyph font cands)) + (if (ly:stencil-empty? (ly:font-get-glyph font cands)) "" cands)) (let* ((font - (ly:paper-get-font layout - (cons '((font-encoding . fetaMusic)) props))) + (ly:paper-get-font layout + (cons '((font-encoding . fetaMusic)) props))) (rest-glyph-name - (let ((result - (get-glyph-name font - (get-glyph-name-candidates log style)))) - (if (string-null? result) + (let ((result + (get-glyph-name font + (get-glyph-name-candidates log style)))) + (if (string-null? result) ;; If no glyph name can be found, select default rests. Though ;; this usually means an unsupported style has been chosen, it ;; also prevents unrelated 'style settings from other grobs @@ -3567,7 +3567,7 @@ A rest or multi-measure-rest symbol. (< log 2) (>= log 0) (not (member style '(neomensural mensural petrucci)))) - (set! dots (ly:stencil-translate-axis dots dot-width X))) + (set! dots (ly:stencil-translate-axis dots dot-width X))) ;; Add dots to the rest-glyph. ;; @@ -3581,13 +3581,13 @@ A rest or multi-measure-rest symbol. (set! rest-glyph (ly:stencil-add (ly:stencil-translate - dots - (cons - (+ (cdr (ly:stencil-extent rest-glyph X)) dot-width) - (if (< log 2) - (interval-center (ly:stencil-extent rest-glyph Y)) - (- (interval-end (ly:stencil-extent rest-glyph Y)) - (/ (* 2 dot-width) 3))))) + dots + (cons + (+ (cdr (ly:stencil-extent rest-glyph X)) dot-width) + (if (< log 2) + (interval-center (ly:stencil-extent rest-glyph Y)) + (- (interval-end (ly:stencil-extent rest-glyph Y)) + (/ (* 2 dot-width) 3))))) rest-glyph))) rest-glyph)) @@ -3631,14 +3631,14 @@ Could be disabled with @code{\\override #'(multi-measure-rest-number . #f)} ;; Store them in a list. ;; example: (mmr-numbers 25) -> '(3 0 0 1) (define (mmr-numbers nmbr) - (let* ((8-bar-glyph (floor (/ nmbr 8))) - (8-remainder (remainder nmbr 8)) - (4-bar-glyph (floor (/ 8-remainder 4))) - (4-remainder (remainder nmbr 4)) - (2-bar-glyph (floor (/ 4-remainder 2))) - (2-remainder (remainder 4-remainder 2)) - (1-bar-glyph (floor (/ 2-remainder 1)))) - (list 8-bar-glyph 4-bar-glyph 2-bar-glyph 1-bar-glyph))) + (let* ((8-bar-glyph (floor (/ nmbr 8))) + (8-remainder (remainder nmbr 8)) + (4-bar-glyph (floor (/ 8-remainder 4))) + (4-remainder (remainder nmbr 4)) + (2-bar-glyph (floor (/ 4-remainder 2))) + (2-remainder (remainder 4-remainder 2)) + (1-bar-glyph (floor (/ 2-remainder 1)))) + (list 8-bar-glyph 4-bar-glyph 2-bar-glyph 1-bar-glyph))) ;; Get the correct mmr-glyphs. ;; Store them in a list. @@ -3646,93 +3646,93 @@ Could be disabled with @code{\\override #'(multi-measure-rest-number . #f)} ;; (get-mmr-glyphs '(1 0 1 0) '("rests.M3" "rests.M2" "rests.M1" "rests.0")) ;; -> ("rests.M3" "rests.M1") (define (get-mmr-glyphs lst1 lst2) - (define (helper l1 l2 l3) - (if (null? l1) - (reverse l3) - (helper (cdr l1) - (cdr l2) - (append (make-list (car l1) (car l2)) l3)))) - (helper lst1 lst2 '())) + (define (helper l1 l2 l3) + (if (null? l1) + (reverse l3) + (helper (cdr l1) + (cdr l2) + (append (make-list (car l1) (car l2)) l3)))) + (helper lst1 lst2 '())) ;; If duration is not valid, print a warning and return empty-stencil (if (or (and (not (integer? (car (parse-simple-duration duration)))) (not multi-measure-rest)) (and (= (string-length (car (string-split duration #\. ))) 1) (= (string->number (car (string-split duration #\. ))) 0))) - (begin - (ly:warning (_ "not a valid duration string: ~a - ignoring") duration) - empty-stencil) - (let* ( - ;; For simple rests: - ;; Get a (log dots) list. - (parsed (parse-simple-duration duration)) - ;; Create the rest-stencil - (stil + (begin + (ly:warning (_ "not a valid duration string: ~a - ignoring") duration) + empty-stencil) + (let* ( + ;; For simple rests: + ;; Get a (log dots) list. + (parsed (parse-simple-duration duration)) + ;; Create the rest-stencil + (stil (rest-by-number-markup layout props (car parsed) (cadr parsed))) - ;; For MultiMeasureRests: - ;; Get the duration-part of duration - (dur-part-string (car (string-split duration #\. ))) - ;; Get the duration of MMR: - ;; If not a number (eg. "maxima") calculate it. - (mmr-duration - (or (string->number dur-part-string) (expt 2 (abs (car parsed))))) - ;; Get a list of the correct number of each mmr-glyph. - (count-mmr-glyphs-list (mmr-numbers mmr-duration)) - ;; Create a list of mmr-stencils, - ;; translating the glyph for a whole rest. - (mmr-stils-list + ;; For MultiMeasureRests: + ;; Get the duration-part of duration + (dur-part-string (car (string-split duration #\. ))) + ;; Get the duration of MMR: + ;; If not a number (eg. "maxima") calculate it. + (mmr-duration + (or (string->number dur-part-string) (expt 2 (abs (car parsed))))) + ;; Get a list of the correct number of each mmr-glyph. + (count-mmr-glyphs-list (mmr-numbers mmr-duration)) + ;; Create a list of mmr-stencils, + ;; translating the glyph for a whole rest. + (mmr-stils-list (map - (lambda (x) - (let ((single-mmr-stil - (rest-by-number-markup layout props (* -1 x) 0))) - (if (= x 0) - (ly:stencil-translate-axis - single-mmr-stil - ;; Ugh, hard-coded, why 1? - 1 - Y) - single-mmr-stil))) - (get-mmr-glyphs count-mmr-glyphs-list (reverse (iota 4))))) - ;; Adjust the space between the mmr-glyphs, - ;; if not default-glyphs are used. - (word-space (if (member style - '(neomensural mensural petrucci)) - (/ (* word-space 2) 3) - word-space)) - ;; Create the final mmr-stencil - ;; via `stack-stencil-line´ from /scm/markup.scm - (mmr-stil (stack-stencil-line word-space mmr-stils-list))) - - ;; Print the number above a multi-measure-rest - ;; Depends on duration, style and multi-measure-rest-number set #t - (if (and multi-measure-rest - multi-measure-rest-number - (> mmr-duration 1) - (not (member style '(neomensural mensural petrucci)))) - (let* ((mmr-stil-x-center - (interval-center (ly:stencil-extent mmr-stil X))) - (duration-markup - (markup - #:fontsize -2 - #:override '(font-encoding . fetaText) - (number->string mmr-duration))) - (mmr-number-stil - (interpret-markup layout props duration-markup)) - (mmr-number-stil-x-center - (interval-center (ly:stencil-extent mmr-number-stil X)))) - - (set! mmr-stil (ly:stencil-combine-at-edge - mmr-stil - Y UP - (ly:stencil-translate-axis - mmr-number-stil - (- mmr-stil-x-center mmr-number-stil-x-center) - X) - ;; Ugh, hardcoded - 0.8)))) - (if multi-measure-rest - mmr-stil - stil)))) + (lambda (x) + (let ((single-mmr-stil + (rest-by-number-markup layout props (* -1 x) 0))) + (if (= x 0) + (ly:stencil-translate-axis + single-mmr-stil + ;; Ugh, hard-coded, why 1? + 1 + Y) + single-mmr-stil))) + (get-mmr-glyphs count-mmr-glyphs-list (reverse (iota 4))))) + ;; Adjust the space between the mmr-glyphs, + ;; if not default-glyphs are used. + (word-space (if (member style + '(neomensural mensural petrucci)) + (/ (* word-space 2) 3) + word-space)) + ;; Create the final mmr-stencil + ;; via `stack-stencil-line´ from /scm/markup.scm + (mmr-stil (stack-stencil-line word-space mmr-stils-list))) + + ;; Print the number above a multi-measure-rest + ;; Depends on duration, style and multi-measure-rest-number set #t + (if (and multi-measure-rest + multi-measure-rest-number + (> mmr-duration 1) + (not (member style '(neomensural mensural petrucci)))) + (let* ((mmr-stil-x-center + (interval-center (ly:stencil-extent mmr-stil X))) + (duration-markup + (markup + #:fontsize -2 + #:override '(font-encoding . fetaText) + (number->string mmr-duration))) + (mmr-number-stil + (interpret-markup layout props duration-markup)) + (mmr-number-stil-x-center + (interval-center (ly:stencil-extent mmr-number-stil X)))) + + (set! mmr-stil (ly:stencil-combine-at-edge + mmr-stil + Y UP + (ly:stencil-translate-axis + mmr-number-stil + (- mmr-stil-x-center mmr-number-stil-x-center) + X) + ;; Ugh, hardcoded + 0.8)))) + (if multi-measure-rest + mmr-stil + stil)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; translating. @@ -3756,7 +3756,7 @@ A negative @var{amount} indicates raising; see also @code{\\raise}. } @end lilypond" (ly:stencil-translate-axis (interpret-markup layout props arg) - (- amount) Y)) + (- amount) Y)) (define-markup-command (translate-scaled layout props offset arg) (number-pair? markup?) @@ -3843,9 +3843,9 @@ Make a fraction of two markups. ;; should stack mols separately, to maintain LINE on baseline (stack (stack-lines DOWN padding baseline (list m1 line m2)))) (set! stack - (ly:stencil-aligned-to stack Y CENTER)) + (ly:stencil-aligned-to stack Y CENTER)) (set! stack - (ly:stencil-aligned-to stack X LEFT)) + (ly:stencil-aligned-to stack X LEFT)) ;; should have EX dimension ;; empirical anyway (ly:stencil-translate-axis stack offset Y)))) @@ -3875,7 +3875,7 @@ Set @var{arg} in superscript with a normal font size. (markup?) #:category font #:properties ((font-size 0) - (baseline-skip)) + (baseline-skip)) " @cindex superscript text @@ -3916,13 +3916,13 @@ is a pair of numbers representing the displacement in the X and Y axis. } @end lilypond" (ly:stencil-translate (interpret-markup layout props arg) - offset)) + offset)) (define-markup-command (sub layout props arg) (markup?) #:category font #:properties ((font-size 0) - (baseline-skip)) + (baseline-skip)) " @cindex subscript text @@ -4017,10 +4017,10 @@ Draw vertical brackets around @var{arg}. (markup?) #:category graphic #:properties ((angularity 0) - (padding) - (size 1) - (thickness 1) - (width 0.25)) + (padding) + (size 1) + (thickness 1) + (width 0.25)) " @cindex placing parentheses around text @@ -4048,14 +4048,14 @@ a column containing several lines of text. } @end lilypond" (let* ((markup (interpret-markup layout props arg)) - (scaled-width (* size width)) - (scaled-thickness - (* (chain-assoc-get 'line-thickness props 0.1) - thickness)) - (half-thickness - (min (* size 0.5 scaled-thickness) - (* (/ 4 3.0) scaled-width))) - (padding (chain-assoc-get 'padding props half-thickness))) + (scaled-width (* size width)) + (scaled-thickness + (* (chain-assoc-get 'line-thickness props 0.1) + thickness)) + (half-thickness + (min (* size 0.5 scaled-thickness) + (* (/ 4 3.0) scaled-width))) + (padding (chain-assoc-get 'padding props half-thickness))) (parenthesize-stencil markup half-thickness scaled-width angularity padding))) @@ -4075,21 +4075,21 @@ page (using the @code{\\label} command), @var{gauge} a markup used to estimate the maximum width of the page number, and @var{default} the value to display when @var{label} is not found." (let* ((gauge-stencil (interpret-markup layout props gauge)) - (x-ext (ly:stencil-extent gauge-stencil X)) - (y-ext (ly:stencil-extent gauge-stencil Y))) + (x-ext (ly:stencil-extent gauge-stencil X)) + (y-ext (ly:stencil-extent gauge-stencil Y))) (ly:make-stencil `(delay-stencil-evaluation ,(delay (ly:stencil-expr - (let* ((table (ly:output-def-lookup layout 'label-page-table)) - (page-number (if (list? table) - (assoc-get label table) - #f)) - (page-markup (if page-number (format #f "~a" page-number) default)) - (page-stencil (interpret-markup layout props page-markup)) - (gap (- (interval-length x-ext) - (interval-length (ly:stencil-extent page-stencil X))))) - (interpret-markup layout props - (markup #:hspace gap page-markup)))))) + (let* ((table (ly:output-def-lookup layout 'label-page-table)) + (page-number (if (list? table) + (assoc-get label table) + #f)) + (page-markup (if page-number (format #f "~a" page-number) default)) + (page-stencil (interpret-markup layout props page-markup)) + (gap (- (interval-length x-ext) + (interval-length (ly:stencil-extent page-stencil X))))) + (interpret-markup layout props + (markup #:hspace gap page-markup)))))) x-ext y-ext))) @@ -4119,8 +4119,8 @@ Negative values may be used to produce mirror images. } @end lilypond" (let ((stil (interpret-markup layout props arg)) - (sx (car factor-pair)) - (sy (cdr factor-pair))) + (sx (car factor-pair)) + (sy (cdr factor-pair))) (ly:stencil-scale stil sx sy))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -4145,20 +4145,20 @@ Patterns are distributed on @var{axis}. } @end lilypond" (let ((pattern-width (interval-length - (ly:stencil-extent (interpret-markup layout props pattern) X))) + (ly:stencil-extent (interpret-markup layout props pattern) X))) (new-props (prepend-alist-chain 'word-space 0 (prepend-alist-chain 'baseline-skip 0 props)))) (let loop ((i (1- count)) (patterns (markup))) (if (zero? i) (interpret-markup - layout - new-props - (if (= axis X) - (markup patterns pattern) - (markup #:column (patterns pattern)))) + layout + new-props + (if (= axis X) + (markup patterns pattern) + (markup #:column (patterns pattern)))) (loop (1- i) - (if (= axis X) - (markup patterns pattern #:hspace space) - (markup #:column (patterns pattern #:vspace space)))))))) + (if (= axis X) + (markup patterns pattern #:hspace space) + (markup #:column (patterns pattern #:vspace space)))))))) (define-markup-command (fill-with-pattern layout props space dir pattern left right) (number? ly:dir? markup? markup? markup?) @@ -4230,29 +4230,29 @@ The @code{key} is the string to be replaced by the @code{value} string. (define-public (space-lines baseline stils) (let space-stil ((stils stils) - (result (list))) + (result (list))) (if (null? stils) - (reverse! result) - (let* ((stil (car stils)) - (dy-top (max (- (/ baseline 1.5) - (interval-bound (ly:stencil-extent stil Y) UP)) - 0.0)) - (dy-bottom (max (+ (/ baseline 3.0) - (interval-bound (ly:stencil-extent stil Y) DOWN)) - 0.0)) - (new-stil (ly:make-stencil - (ly:stencil-expr stil) - (ly:stencil-extent stil X) - (cons (- (interval-bound (ly:stencil-extent stil Y) DOWN) - dy-bottom) - (+ (interval-bound (ly:stencil-extent stil Y) UP) - dy-top))))) - (space-stil (cdr stils) (cons new-stil result)))))) + (reverse! result) + (let* ((stil (car stils)) + (dy-top (max (- (/ baseline 1.5) + (interval-bound (ly:stencil-extent stil Y) UP)) + 0.0)) + (dy-bottom (max (+ (/ baseline 3.0) + (interval-bound (ly:stencil-extent stil Y) DOWN)) + 0.0)) + (new-stil (ly:make-stencil + (ly:stencil-expr stil) + (ly:stencil-extent stil X) + (cons (- (interval-bound (ly:stencil-extent stil Y) DOWN) + dy-bottom) + (+ (interval-bound (ly:stencil-extent stil Y) UP) + dy-top))))) + (space-stil (cdr stils) (cons new-stil result)))))) (define-markup-list-command (justified-lines layout props args) (markup-list?) #:properties ((baseline-skip) - wordwrap-internal-markup-list) + wordwrap-internal-markup-list) " @cindex justifying lines of text @@ -4266,7 +4266,7 @@ Use @code{\\override-lines #'(line-width . @var{X})} to set the line width; (define-markup-list-command (wordwrap-lines layout props args) (markup-list?) #:properties ((baseline-skip) - wordwrap-internal-markup-list) + wordwrap-internal-markup-list) "Like @code{\\wordwrap}, but return a list of lines instead of a single markup. Use @code{\\override-lines #'(line-width . @var{X})} to set the line width, where @var{X} is the number of staff spaces." @@ -4280,7 +4280,7 @@ where @var{X} is the number of staff spaces." "Like @code{\\column}, but return a list of lines instead of a single markup. @code{baseline-skip} determines the space between each markup in @var{args}." (space-lines baseline-skip - (interpret-markup-list layout props args))) + (interpret-markup-list layout props args))) (define-markup-list-command (override-lines layout props new-prop args) (pair? markup-list?) diff --git a/scm/define-music-callbacks.scm b/scm/define-music-callbacks.scm index 723ed130ec..42aaf58ace 100644 --- a/scm/define-music-callbacks.scm +++ b/scm/define-music-callbacks.scm @@ -1,7 +1,7 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; ;;;; Copyright (C) 1998--2012 Han-Wen Nienhuys <hanwen@xs4all.nl> -;;;; Jan Nieuwenhuizen <janneke@gnu.org> +;;;; Jan Nieuwenhuizen <janneke@gnu.org> ;;;; Neil Puttock <n.puttock@gmail.com> ;;;; Carl Sorensen <c_sorensen@byu.edu> ;;;; @@ -24,15 +24,15 @@ "Generate events for multimeasure rests, to be used by the sequential-iterator" (let ((location (ly:music-property music 'origin)) - (duration (ly:music-property music 'duration))) + (duration (ly:music-property music 'duration))) (list (make-music 'BarCheck - 'origin location) - (make-event-chord (cons (make-music 'MultiMeasureRestEvent - 'origin location - 'duration duration) - (ly:music-property music 'articulations))) - (make-music 'BarCheck - 'origin location)))) + 'origin location) + (make-event-chord (cons (make-music 'MultiMeasureRestEvent + 'origin location + 'duration duration) + (ly:music-property music 'articulations))) + (make-music 'BarCheck + 'origin location)))) (define (make-volta-set music) (let* ((alts (ly:music-property music 'elements)) @@ -40,25 +40,25 @@ to be used by the sequential-iterator" (times (ly:music-property music 'repeat-count))) (map (lambda (x y) (make-music - 'SequentialMusic - 'elements - ;; set properties for proper bar numbering - (append + 'SequentialMusic + 'elements + ;; set properties for proper bar numbering + (append + (list (make-music 'AlternativeEvent + 'alternative-dir (if (= y 0) + -1 + 0) + 'alternative-increment + (if (= 0 y) + (1+ (- times + lalts)) + 1))) + (list x) + (if (= y (1- lalts)) (list (make-music 'AlternativeEvent - 'alternative-dir (if (= y 0) - -1 - 0) - 'alternative-increment - (if (= 0 y) - (1+ (- times - lalts)) - 1))) - (list x) - (if (= y (1- lalts)) - (list (make-music 'AlternativeEvent - 'alternative-dir 1 - 'alternative-increment 0)) - '())))) + 'alternative-dir 1 + 'alternative-increment 0)) + '())))) alts (iota lalts)))) @@ -67,18 +67,18 @@ to be used by the sequential-iterator" (let ((octavation (ly:music-property music 'ottava-number))) (list (context-spec-music - (make-apply-context - (lambda (context) - (let ((offset (* -7 octavation)) - (string (assoc-get octavation '((2 . "15ma") - (1 . "8va") - (0 . #f) - (-1 . "8vb") - (-2 . "15mb"))))) - (set! (ly:context-property context 'middleCOffset) offset) - (set! (ly:context-property context 'ottavation) string) - (ly:set-middle-C! context)))) - 'Staff)))) + (make-apply-context + (lambda (context) + (let ((offset (* -7 octavation)) + (string (assoc-get octavation '((2 . "15ma") + (1 . "8va") + (0 . #f) + (-1 . "8vb") + (-2 . "15mb"))))) + (set! (ly:context-property context 'middleCOffset) offset) + (set! (ly:context-property context 'ottavation) string) + (ly:set-middle-C! context)))) + 'Staff)))) (define (make-time-signature-set music) "Set context properties for a time signature." @@ -87,31 +87,31 @@ to be used by the sequential-iterator" (structure (ly:music-property music 'beat-structure)) (fraction (cons num den))) (list (descend-to-context - (context-spec-music - (make-apply-context - (lambda (context) - (let* ((time-signature-settings - (ly:context-property context 'timeSignatureSettings)) - (my-base-length - (base-length fraction time-signature-settings)) - (my-beat-structure - (if (null? structure) - (beat-structure my-base-length - fraction - time-signature-settings) - structure)) - (beaming-exception - (beam-exceptions fraction time-signature-settings)) - (new-measure-length (ly:make-moment num den))) - (ly:context-set-property! - context 'timeSignatureFraction fraction) - (ly:context-set-property! - context 'baseMoment (ly:make-moment my-base-length)) - (ly:context-set-property! - context 'beatStructure my-beat-structure) - (ly:context-set-property! - context 'beamExceptions beaming-exception) - (ly:context-set-property! - context 'measureLength new-measure-length)))) - 'Timing) - 'Score)))) + (context-spec-music + (make-apply-context + (lambda (context) + (let* ((time-signature-settings + (ly:context-property context 'timeSignatureSettings)) + (my-base-length + (base-length fraction time-signature-settings)) + (my-beat-structure + (if (null? structure) + (beat-structure my-base-length + fraction + time-signature-settings) + structure)) + (beaming-exception + (beam-exceptions fraction time-signature-settings)) + (new-measure-length (ly:make-moment num den))) + (ly:context-set-property! + context 'timeSignatureFraction fraction) + (ly:context-set-property! + context 'baseMoment (ly:make-moment my-base-length)) + (ly:context-set-property! + context 'beatStructure my-beat-structure) + (ly:context-set-property! + context 'beamExceptions beaming-exception) + (ly:context-set-property! + context 'measureLength new-measure-length)))) + 'Timing) + 'Score)))) diff --git a/scm/define-music-display-methods.scm b/scm/define-music-display-methods.scm index 82e227c8f5..6d9dc82506 100644 --- a/scm/define-music-display-methods.scm +++ b/scm/define-music-display-methods.scm @@ -18,21 +18,21 @@ (cond ((or (number? scm-arg) (string? scm-arg) (boolean? scm-arg)) - (format #f "~s" scm-arg)) - ((or (symbol? scm-arg) - (list? scm-arg)) - (format #f "'~s" scm-arg)) - ((procedure? scm-arg) - (format #f "~a" - (or (procedure-name scm-arg) - (with-output-to-string - (lambda () - (pretty-print (procedure-source scm-arg))))))) - (else - (format #f "~a" - (with-output-to-string - (lambda () - (display-scheme-music scm-arg))))))) + (format #f "~s" scm-arg)) + ((or (symbol? scm-arg) + (list? scm-arg)) + (format #f "'~s" scm-arg)) + ((procedure? scm-arg) + (format #f "~a" + (or (procedure-name scm-arg) + (with-output-to-string + (lambda () + (pretty-print (procedure-source scm-arg))))))) + (else + (format #f "~a" + (with-output-to-string + (lambda () + (display-scheme-music scm-arg))))))) ;;; ;;; Markups ;;; @@ -43,33 +43,33 @@ expression." (define (proc->command proc) (let ((cmd-markup (symbol->string (procedure-name proc)))) (substring cmd-markup 0 (- (string-length cmd-markup) - (string-length "-markup"))))) + (string-length "-markup"))))) (define (arg->string arg) (cond ((string? arg) - (format #f "~s" arg)) - ((markup? arg) ;; a markup - (markup->lily-string-aux arg)) - ((and (pair? arg) (every markup? arg)) ;; a markup list - (format #f "{~{ ~a~}}" (map-in-order markup->lily-string-aux arg))) - (else ;; a scheme argument - (format #f "#~a" (scheme-expr->lily-string arg))))) + (format #f "~s" arg)) + ((markup? arg) ;; a markup + (markup->lily-string-aux arg)) + ((and (pair? arg) (every markup? arg)) ;; a markup list + (format #f "{~{ ~a~}}" (map-in-order markup->lily-string-aux arg))) + (else ;; a scheme argument + (format #f "#~a" (scheme-expr->lily-string arg))))) (define (markup->lily-string-aux expr) (if (string? expr) - (format #f "~s" expr) - (let ((cmd (car expr)) - (args (cdr expr))) - (if (eqv? cmd simple-markup) ;; a simple markup - (format #f "~s" (car args)) - (format #f "\\~a~{ ~a~}" - (proc->command cmd) - (map-in-order arg->string args)))))) + (format #f "~s" expr) + (let ((cmd (car expr)) + (args (cdr expr))) + (if (eqv? cmd simple-markup) ;; a simple markup + (format #f "~s" (car args)) + (format #f "\\~a~{ ~a~}" + (proc->command cmd) + (map-in-order arg->string args)))))) (cond ((string? markup-expr) - (format #f "~s" markup-expr)) - ((eqv? (car markup-expr) simple-markup) - (format #f "~s" (second markup-expr))) - (else - (format #f "\\markup ~a" - (markup->lily-string-aux markup-expr))))) + (format #f "~s" markup-expr)) + ((eqv? (car markup-expr) simple-markup) + (format #f "~s" (second markup-expr))) + (else + (format #f "\\markup ~a" + (markup->lily-string-aux markup-expr))))) ;;; ;;; pitch names @@ -81,49 +81,49 @@ expression." (result #f result)) ((or result (null? alist)) result) (if (and (car alist) (test item (cdar alist))) - (set! result (car alist))))) + (set! result (car alist))))) (define-public (note-name->lily-string ly-pitch parser) ;; here we define a custom pitch= function, since we do not want to ;; test whether octaves are also equal. (otherwise, we would be using equal?) (define (pitch= pitch1 pitch2) (and (= (ly:pitch-notename pitch1) (ly:pitch-notename pitch2)) - (= (ly:pitch-alteration pitch1) (ly:pitch-alteration pitch2)))) + (= (ly:pitch-alteration pitch1) (ly:pitch-alteration pitch2)))) (let ((result (rassoc ly-pitch (ly:parser-lookup parser 'pitchnames) pitch=))) (if result - (car result) - #f))) + (car result) + #f))) (define-public (octave->lily-string pitch) (let ((octave (ly:pitch-octave pitch))) (cond ((>= octave 0) - (make-string (1+ octave) #\')) - ((< octave -1) - (make-string (1- (* -1 octave)) #\,)) - (else "")))) + (make-string (1+ octave) #\')) + ((< octave -1) + (make-string (1- (* -1 octave)) #\,)) + (else "")))) ;;; ;;; durations ;;; (define*-public (duration->lily-string ly-duration #:key (prev-duration (*previous-duration*)) - (force-duration (*force-duration*)) - (time-scale (*time-scale*)) - remember) + (force-duration (*force-duration*)) + (time-scale (*time-scale*)) + remember) (if remember (*previous-duration* ly-duration)) - (let ((log2 (ly:duration-log ly-duration)) - (dots (ly:duration-dot-count ly-duration)) - (scale (ly:duration-scale ly-duration))) + (let ((log2 (ly:duration-log ly-duration)) + (dots (ly:duration-dot-count ly-duration)) + (scale (ly:duration-scale ly-duration))) (if (or force-duration (not prev-duration) (not (equal? ly-duration prev-duration))) - (string-append (case log2 - ((-1) "\\breve") - ((-2) "\\longa") - ((-3) "\\maxima") - (else (number->string (expt 2 log2)))) - (make-string dots #\.) - (let ((end-scale (/ scale time-scale))) - (if (= end-scale 1) "" - (format #f "*~a" end-scale)))) - ""))) + (string-append (case log2 + ((-1) "\\breve") + ((-2) "\\longa") + ((-3) "\\maxima") + (else (number->string (expt 2 log2)))) + (make-string dots #\.) + (let ((end-scale (/ scale time-scale))) + (if (= end-scale 1) "" + (format #f "*~a" end-scale)))) + ""))) ;;; ;;; post events @@ -135,24 +135,24 @@ expression." (define* (event-direction->lily-string event #:optional (required #t)) (let ((direction (ly:music-property event 'direction))) (cond ((or (not direction) (null? direction) (= CENTER direction)) - (if required "-" "")) - ((= UP direction) "^") - ((= DOWN direction) "_") - (else "")))) + (if required "-" "")) + ((= UP direction) "^") + ((= DOWN direction) "_") + (else "")))) (define-macro (define-post-event-display-method type vars direction-required str) `(define-display-method ,type ,vars (format #f "~a~a" - (event-direction->lily-string ,(car vars) ,direction-required) - ,str))) + (event-direction->lily-string ,(car vars) ,direction-required) + ,str))) (define-macro (define-span-event-display-method type vars direction-required str-start str-stop) `(define-display-method ,type ,vars (format #f "~a~a" - (event-direction->lily-string ,(car vars) ,direction-required) - (if (= START (ly:music-property ,(car vars) 'span-direction)) - ,str-start - ,str-stop)))) + (event-direction->lily-string ,(car vars) ,direction-required) + (if (= START (ly:music-property ,(car vars) 'span-direction)) + ,str-start + ,str-stop)))) (define-display-method HyphenEvent (event parser) " --") @@ -169,25 +169,25 @@ expression." (define-display-method TremoloEvent (event parser) (let ((tremolo-type (ly:music-property event 'tremolo-type))) (format #f ":~a" (if (= 0 tremolo-type) - "" - tremolo-type)))) + "" + tremolo-type)))) (define-display-method ArticulationEvent (event parser) #t (let* ((articulation (ly:music-property event 'articulation-type)) - (shorthand - (case (string->symbol articulation) - ((marcato) "^") - ((stopped) "+") - ((tenuto) "-") - ((staccatissimo) "|") - ((accent) ">") - ((staccato) ".") - ((portato) "_") - (else #f)))) + (shorthand + (case (string->symbol articulation) + ((marcato) "^") + ((stopped) "+") + ((tenuto) "-") + ((staccatissimo) "|") + ((accent) ">") + ((staccato) ".") + ((portato) "_") + (else #f)))) (format #f "~a~:[\\~;~]~a" - (event-direction->lily-string event shorthand) - shorthand - (or shorthand articulation)))) + (event-direction->lily-string event shorthand) + shorthand + (or shorthand articulation)))) (define-post-event-display-method FingeringEvent (event parser) #t (ly:music-property event 'digit)) @@ -230,7 +230,7 @@ expression." (define-display-method GraceMusic (expr parser) (format #f "\\grace ~a" - (music->lily-string (ly:music-property expr 'element) parser))) + (music->lily-string (ly:music-property expr 'element) parser))) ;; \acciaccatura \appoggiatura \grace ;; TODO: it would be better to compare ?start and ?stop @@ -239,92 +239,92 @@ expression." (define-extra-display-method GraceMusic (expr parser) "Display method for appoggiatura." (with-music-match (expr (music - 'GraceMusic - element (music - 'SequentialMusic - elements (?start - ?music - ?stop)))) - ;; we check whether ?start and ?stop look like - ;; startAppoggiaturaMusic stopAppoggiaturaMusic - (and (with-music-match (?start (music - 'SequentialMusic - elements ((music - 'EventChord - elements - ((music - 'SlurEvent - span-direction START)))))) - #t) - (with-music-match (?stop (music - 'SequentialMusic - elements ((music - 'EventChord - elements - ((music - 'SlurEvent - span-direction STOP)))))) - (format #f "\\appoggiatura ~a" (music->lily-string ?music parser)))))) + 'GraceMusic + element (music + 'SequentialMusic + elements (?start + ?music + ?stop)))) + ;; we check whether ?start and ?stop look like + ;; startAppoggiaturaMusic stopAppoggiaturaMusic + (and (with-music-match (?start (music + 'SequentialMusic + elements ((music + 'EventChord + elements + ((music + 'SlurEvent + span-direction START)))))) + #t) + (with-music-match (?stop (music + 'SequentialMusic + elements ((music + 'EventChord + elements + ((music + 'SlurEvent + span-direction STOP)))))) + (format #f "\\appoggiatura ~a" (music->lily-string ?music parser)))))) (define-extra-display-method GraceMusic (expr parser) "Display method for acciaccatura." (with-music-match (expr (music - 'GraceMusic - element (music - 'SequentialMusic - elements (?start - ?music - ?stop)))) - ;; we check whether ?start and ?stop look like - ;; startAcciaccaturaMusic stopAcciaccaturaMusic - (and (with-music-match (?start (music - 'SequentialMusic - elements ((music - 'EventChord - elements - ((music - 'SlurEvent - span-direction START))) - (music - 'ContextSpeccedMusic - element (music - 'OverrideProperty - grob-property-path '(stroke-style) - grob-value "grace" - symbol 'Flag))))) - #t) - (with-music-match (?stop (music - 'SequentialMusic - elements ((music - 'ContextSpeccedMusic - element (music - 'RevertProperty - grob-property-path '(stroke-style) - symbol 'Flag)) - - (music - 'EventChord - elements - ((music - 'SlurEvent - span-direction STOP)))))) - (format #f "\\acciaccatura ~a" (music->lily-string ?music parser)))))) + 'GraceMusic + element (music + 'SequentialMusic + elements (?start + ?music + ?stop)))) + ;; we check whether ?start and ?stop look like + ;; startAcciaccaturaMusic stopAcciaccaturaMusic + (and (with-music-match (?start (music + 'SequentialMusic + elements ((music + 'EventChord + elements + ((music + 'SlurEvent + span-direction START))) + (music + 'ContextSpeccedMusic + element (music + 'OverrideProperty + grob-property-path '(stroke-style) + grob-value "grace" + symbol 'Flag))))) + #t) + (with-music-match (?stop (music + 'SequentialMusic + elements ((music + 'ContextSpeccedMusic + element (music + 'RevertProperty + grob-property-path '(stroke-style) + symbol 'Flag)) + + (music + 'EventChord + elements + ((music + 'SlurEvent + span-direction STOP)))))) + (format #f "\\acciaccatura ~a" (music->lily-string ?music parser)))))) (define-extra-display-method GraceMusic (expr parser) "Display method for grace." (with-music-match (expr (music - 'GraceMusic - element (music - 'SequentialMusic - elements (?start - ?music - ?stop)))) - ;; we check whether ?start and ?stop look like - ;; startGraceMusic stopGraceMusic - (and (null? (ly:music-property ?start 'elements)) - (null? (ly:music-property ?stop 'elements)) - (format #f "\\grace ~a" (music->lily-string ?music parser))))) + 'GraceMusic + element (music + 'SequentialMusic + elements (?start + ?music + ?stop)))) + ;; we check whether ?start and ?stop look like + ;; startGraceMusic stopGraceMusic + (and (null? (ly:music-property ?start 'elements)) + (null? (ly:music-property ?stop 'elements)) + (format #f "\\grace ~a" (music->lily-string ?music parser))))) ;;; ;;; Music sequences @@ -332,79 +332,79 @@ expression." (define-display-method SequentialMusic (seq parser) (let ((force-line-break (and (*force-line-break*) - ;; hm - (> (length (ly:music-property seq 'elements)) - (*max-element-number-before-break*)))) - (elements (ly:music-property seq 'elements)) - (chord? (make-music-type-predicate 'EventChord)) - (note-or-chord? (make-music-type-predicate 'EventChord 'NoteEvent - 'LyricEvent 'RestEvent - 'ClusterNoteEvent)) - (cluster? (make-music-type-predicate 'ClusterNoteEvent)) - (note? (make-music-type-predicate 'NoteEvent))) + ;; hm + (> (length (ly:music-property seq 'elements)) + (*max-element-number-before-break*)))) + (elements (ly:music-property seq 'elements)) + (chord? (make-music-type-predicate 'EventChord)) + (note-or-chord? (make-music-type-predicate 'EventChord 'NoteEvent + 'LyricEvent 'RestEvent + 'ClusterNoteEvent)) + (cluster? (make-music-type-predicate 'ClusterNoteEvent)) + (note? (make-music-type-predicate 'NoteEvent))) (format #f "~a~a{~v%~v_~{~a~^ ~}~v%~v_}" - (if (any (lambda (e) - (or (cluster? e) - (and (chord? e) - (any cluster? (ly:music-property e 'elements))))) - elements) - "\\makeClusters " - "") - (if (*explicit-mode*) - ;; if the sequence contains EventChord which contains figures ==> figuremode - ;; if the sequence contains EventChord which contains lyrics ==> lyricmode - ;; if the sequence contains EventChord which contains drum notes ==> drummode - (cond ((any (lambda (chord) - (any (make-music-type-predicate 'BassFigureEvent) - (ly:music-property chord 'elements))) - (filter chord? elements)) - "\\figuremode ") - ((any (lambda (chord) - (any (make-music-type-predicate 'LyricEvent) - (cons chord - (ly:music-property chord 'elements)))) - (filter note-or-chord? elements)) - "\\lyricmode ") - ((any (lambda (chord) - (any (lambda (event) - (and (note? event) - (not (null? (ly:music-property event 'drum-type))))) - (cons chord - (ly:music-property chord 'elements)))) - (filter note-or-chord? elements)) - "\\drummode ") - (else ;; TODO: other modes? - "")) - "") - (if force-line-break 1 0) - (if force-line-break (+ 2 (*indent*)) 1) - (parameterize ((*indent* (+ 2 (*indent*)))) - (map-in-order (lambda (music) - (music->lily-string music parser)) - elements)) - (if force-line-break 1 0) - (if force-line-break (*indent*) 1)))) + (if (any (lambda (e) + (or (cluster? e) + (and (chord? e) + (any cluster? (ly:music-property e 'elements))))) + elements) + "\\makeClusters " + "") + (if (*explicit-mode*) + ;; if the sequence contains EventChord which contains figures ==> figuremode + ;; if the sequence contains EventChord which contains lyrics ==> lyricmode + ;; if the sequence contains EventChord which contains drum notes ==> drummode + (cond ((any (lambda (chord) + (any (make-music-type-predicate 'BassFigureEvent) + (ly:music-property chord 'elements))) + (filter chord? elements)) + "\\figuremode ") + ((any (lambda (chord) + (any (make-music-type-predicate 'LyricEvent) + (cons chord + (ly:music-property chord 'elements)))) + (filter note-or-chord? elements)) + "\\lyricmode ") + ((any (lambda (chord) + (any (lambda (event) + (and (note? event) + (not (null? (ly:music-property event 'drum-type))))) + (cons chord + (ly:music-property chord 'elements)))) + (filter note-or-chord? elements)) + "\\drummode ") + (else ;; TODO: other modes? + "")) + "") + (if force-line-break 1 0) + (if force-line-break (+ 2 (*indent*)) 1) + (parameterize ((*indent* (+ 2 (*indent*)))) + (map-in-order (lambda (music) + (music->lily-string music parser)) + elements)) + (if force-line-break 1 0) + (if force-line-break (*indent*) 1)))) (define-display-method SimultaneousMusic (sim parser) (parameterize ((*indent* (+ 3 (*indent*)))) - (format #f "<< ~{~a ~}>>" - (map-in-order (lambda (music) - (music->lily-string music parser)) - (ly:music-property sim 'elements))))) + (format #f "<< ~{~a ~}>>" + (map-in-order (lambda (music) + (music->lily-string music parser)) + (ly:music-property sim 'elements))))) (define-extra-display-method SimultaneousMusic (expr parser) "If `sim' is an \afterGrace expression, return \"\\afterGrace ...\". Otherwise, return #f." ;; TODO: do something with afterGraceFraction? (with-music-match (expr (music 'SimultaneousMusic - elements (?before-grace - (music 'SequentialMusic - elements ((music 'SkipMusic) - (music 'GraceMusic - element ?grace)))))) - (format #f "\\afterGrace ~a ~a" - (music->lily-string ?before-grace parser) - (music->lily-string ?grace parser)))) + elements (?before-grace + (music 'SequentialMusic + elements ((music 'SkipMusic) + (music 'GraceMusic + element ?grace)))))) + (format #f "\\afterGrace ~a ~a" + (music->lily-string ?before-grace parser) + (music->lily-string ?grace parser)))) ;;; ;;; Chords @@ -412,68 +412,68 @@ Otherwise, return #f." (define-display-method EventChord (chord parser) ;; event_chord : command_element - ;; | note_chord_element + ;; | note_chord_element ;; TODO : tagged post_events ;; post_events : ( post_event | tagged_post_event )* ;; tagged_post_event: '-' \tag embedded_scm post_event (let* ((elements (append (ly:music-property chord 'elements) - (ly:music-property chord 'articulations))) - (chord-repeat (ly:music-property chord 'duration))) + (ly:music-property chord 'articulations))) + (chord-repeat (ly:music-property chord 'duration))) (call-with-values - (lambda () - (partition (lambda (m) (music-is-of-type? m 'rhythmic-event)) - elements)) + (lambda () + (partition (lambda (m) (music-is-of-type? m 'rhythmic-event)) + elements)) (lambda (chord-elements other-elements) - (cond ((pair? chord-elements) - ;; note_chord_element : - ;; '<' (notepitch | drumpitch)* '>" duration post_events - (let ((duration (duration->lily-string (ly:music-property - (car chord-elements) - 'duration) - #:remember #t))) - ;; Format duration first so that it does not appear on - ;; chord elements - (format #f "< ~{~a ~}>~a~:{~:[-~;~]~a~^ ~}" - (map-in-order (lambda (music) - (music->lily-string music parser)) - chord-elements) - duration - (map-in-order (lambda (music) - (list - (post-event? music) - (music->lily-string music parser))) - other-elements)))) - ((ly:duration? chord-repeat) - (let ((duration (duration->lily-string chord-repeat - #:remember #t))) - (format #f "q~a~:{~:[-~;~]~a~^ ~}" - duration - (map-in-order (lambda (music) - (list - (post-event? music) - (music->lily-string music parser))) - other-elements)))) - - ((and (= 1 (length other-elements)) - (not (post-event? (car other-elements)))) - (format #f (music->lily-string (car other-elements) parser))) - (else - (format #f "< >~:{~:[-~;~]~a~^ ~}" - (map-in-order (lambda (music) - (list - (post-event? music) - (music->lily-string music parser))) - other-elements)))))))) + (cond ((pair? chord-elements) + ;; note_chord_element : + ;; '<' (notepitch | drumpitch)* '>" duration post_events + (let ((duration (duration->lily-string (ly:music-property + (car chord-elements) + 'duration) + #:remember #t))) + ;; Format duration first so that it does not appear on + ;; chord elements + (format #f "< ~{~a ~}>~a~:{~:[-~;~]~a~^ ~}" + (map-in-order (lambda (music) + (music->lily-string music parser)) + chord-elements) + duration + (map-in-order (lambda (music) + (list + (post-event? music) + (music->lily-string music parser))) + other-elements)))) + ((ly:duration? chord-repeat) + (let ((duration (duration->lily-string chord-repeat + #:remember #t))) + (format #f "q~a~:{~:[-~;~]~a~^ ~}" + duration + (map-in-order (lambda (music) + (list + (post-event? music) + (music->lily-string music parser))) + other-elements)))) + + ((and (= 1 (length other-elements)) + (not (post-event? (car other-elements)))) + (format #f (music->lily-string (car other-elements) parser))) + (else + (format #f "< >~:{~:[-~;~]~a~^ ~}" + (map-in-order (lambda (music) + (list + (post-event? music) + (music->lily-string music parser))) + other-elements)))))))) (define-display-method MultiMeasureRestMusic (mmrest parser) (format #f "R~a~{~a~^ ~}" - (duration->lily-string (ly:music-property mmrest 'duration) - #:remember #t) - (map-in-order (lambda (music) - (music->lily-string music parser)) - (ly:music-property mmrest 'articulations)))) + (duration->lily-string (ly:music-property mmrest 'duration) + #:remember #t) + (map-in-order (lambda (music) + (music->lily-string music parser)) + (ly:music-property mmrest 'articulations)))) (define-display-method SkipMusic (skip parser) (format #f "\\skip ~a" (duration->lily-string (ly:music-property skip 'duration) #:force-duration #t))) @@ -487,47 +487,47 @@ Otherwise, return #f." (define (simple-note->lily-string event parser) (format #f "~a~a~a~a~a~a~:{~:[-~;~]~a~}" ; pitchname octave !? octave-check duration optional_rest articulations - (note-name->lily-string (ly:music-property event 'pitch) parser) - (octave->lily-string (ly:music-property event 'pitch)) - (let ((forced (ly:music-property event 'force-accidental)) - (cautionary (ly:music-property event 'cautionary))) - (cond ((and (not (null? forced)) - forced - (not (null? cautionary)) - cautionary) - "?") - ((and (not (null? forced)) forced) "!") - (else ""))) - (let ((octave-check (ly:music-property event 'absolute-octave))) - (if (not (null? octave-check)) - (format #f "=~a" (cond ((>= octave-check 0) - (make-string (1+ octave-check) #\')) - ((< octave-check -1) - (make-string (1- (* -1 octave-check)) #\,)) - (else ""))) - "")) - (duration->lily-string (ly:music-property event 'duration) - #:remember #t) - (if ((make-music-type-predicate 'RestEvent) event) - "\\rest" "") - (map-in-order (lambda (event) - (list - (post-event? event) - (music->lily-string event parser))) - (ly:music-property event 'articulations)))) + (note-name->lily-string (ly:music-property event 'pitch) parser) + (octave->lily-string (ly:music-property event 'pitch)) + (let ((forced (ly:music-property event 'force-accidental)) + (cautionary (ly:music-property event 'cautionary))) + (cond ((and (not (null? forced)) + forced + (not (null? cautionary)) + cautionary) + "?") + ((and (not (null? forced)) forced) "!") + (else ""))) + (let ((octave-check (ly:music-property event 'absolute-octave))) + (if (not (null? octave-check)) + (format #f "=~a" (cond ((>= octave-check 0) + (make-string (1+ octave-check) #\')) + ((< octave-check -1) + (make-string (1- (* -1 octave-check)) #\,)) + (else ""))) + "")) + (duration->lily-string (ly:music-property event 'duration) + #:remember #t) + (if ((make-music-type-predicate 'RestEvent) event) + "\\rest" "") + (map-in-order (lambda (event) + (list + (post-event? event) + (music->lily-string event parser))) + (ly:music-property event 'articulations)))) (define-display-method NoteEvent (note parser) (cond ((not (null? (ly:music-property note 'pitch))) ;; note - (simple-note->lily-string note parser)) - ((not (null? (ly:music-property note 'drum-type))) ;; drum - (format #f "~a~a~{~a~}" (ly:music-property note 'drum-type) - (duration->lily-string (ly:music-property note 'duration) - #:remember #t) - (map-in-order (lambda (event) - (music->lily-string event parser)) - (ly:music-property note 'articulations)))) - (else ;; unknown? - ""))) + (simple-note->lily-string note parser)) + ((not (null? (ly:music-property note 'drum-type))) ;; drum + (format #f "~a~a~{~a~}" (ly:music-property note 'drum-type) + (duration->lily-string (ly:music-property note 'duration) + #:remember #t) + (map-in-order (lambda (event) + (music->lily-string event parser)) + (ly:music-property note 'articulations)))) + (else ;; unknown? + ""))) (define-display-method ClusterNoteEvent (note parser) (simple-note->lily-string note parser)) @@ -536,23 +536,23 @@ Otherwise, return #f." (if (not (null? (ly:music-property rest 'pitch))) (simple-note->lily-string rest parser) (format #f "r~a~{~a~}" - (duration->lily-string (ly:music-property rest 'duration) - #:remember #t) - (map-in-order (lambda (event) - (music->lily-string event parser)) - (ly:music-property rest 'articulations))))) + (duration->lily-string (ly:music-property rest 'duration) + #:remember #t) + (map-in-order (lambda (event) + (music->lily-string event parser)) + (ly:music-property rest 'articulations))))) (define-display-method MultiMeasureRestEvent (rest parser) (string-append "R" (duration->lily-string (ly:music-property rest 'duration) - #:remember #t))) + #:remember #t))) (define-display-method SkipEvent (rest parser) (format #f "s~a~{~a~}" - (duration->lily-string (ly:music-property rest 'duration) - #:remember #t) - (map-in-order (lambda (event) - (music->lily-string event parser)) - (ly:music-property rest 'articulations)))) + (duration->lily-string (ly:music-property rest 'duration) + #:remember #t) + (map-in-order (lambda (event) + (music->lily-string event parser)) + (ly:music-property rest 'articulations)))) (define-display-method RepeatedChord (chord parser) (music->lily-string (ly:music-property chord 'element) parser)) @@ -560,32 +560,32 @@ Otherwise, return #f." (define-display-method MarkEvent (mark parser) (let ((label (ly:music-property mark 'label))) (if (null? label) - "\\mark \\default" - (format #f "\\mark ~a" (markup->lily-string label))))) + "\\mark \\default" + (format #f "\\mark ~a" (markup->lily-string label))))) (define-display-method KeyChangeEvent (key parser) (let ((pitch-alist (ly:music-property key 'pitch-alist)) - (tonic (ly:music-property key 'tonic))) + (tonic (ly:music-property key 'tonic))) (if (or (null? pitch-alist) - (null? tonic)) - "\\key \\default" - (let ((c-pitch-alist (ly:transpose-key-alist pitch-alist - (ly:pitch-diff (ly:make-pitch 0 0 0) tonic)))) - (format #f "\\key ~a \\~a~a" - (note-name->lily-string (ly:music-property key 'tonic) parser) - (any (lambda (mode) - (if (and parser - (equal? (ly:parser-lookup parser mode) c-pitch-alist)) - (symbol->string mode) - #f)) - '(major minor ionian locrian aeolian mixolydian lydian phrygian dorian)) - (new-line->lily-string)))))) + (null? tonic)) + "\\key \\default" + (let ((c-pitch-alist (ly:transpose-key-alist pitch-alist + (ly:pitch-diff (ly:make-pitch 0 0 0) tonic)))) + (format #f "\\key ~a \\~a~a" + (note-name->lily-string (ly:music-property key 'tonic) parser) + (any (lambda (mode) + (if (and parser + (equal? (ly:parser-lookup parser mode) c-pitch-alist)) + (symbol->string mode) + #f)) + '(major minor ionian locrian aeolian mixolydian lydian phrygian dorian)) + (new-line->lily-string)))))) (define-display-method RelativeOctaveCheck (octave parser) (let ((pitch (ly:music-property octave 'pitch))) (format #f "\\octaveCheck ~a~a" - (note-name->lily-string pitch parser) - (octave->lily-string pitch)))) + (note-name->lily-string pitch parser) + (octave->lily-string pitch)))) (define-display-method VoiceSeparator (sep parser) "\\\\") @@ -603,42 +603,42 @@ Otherwise, return #f." (define-display-method BassFigureEvent (figure parser) (let ((alteration (ly:music-property figure 'alteration)) - (fig (ly:music-property figure 'figure)) - (bracket-start (ly:music-property figure 'bracket-start)) - (bracket-stop (ly:music-property figure 'bracket-stop))) + (fig (ly:music-property figure 'figure)) + (bracket-start (ly:music-property figure 'bracket-start)) + (bracket-stop (ly:music-property figure 'bracket-stop))) (format #f "~a~a~a~a" - (if (null? bracket-start) "" "[") - (cond ((null? fig) "_") - ((markup? fig) (second fig)) ;; fig: (<number-markup> "number") - (else fig)) - (if (null? alteration) - "" - (cond - ((= alteration DOUBLE-FLAT) "--") - ((= alteration FLAT) "-") - ((= alteration NATURAL) "!") - ((= alteration SHARP) "+") - ((= alteration DOUBLE-SHARP) "++") - (else ""))) - (if (null? bracket-stop) "" "]")))) + (if (null? bracket-start) "" "[") + (cond ((null? fig) "_") + ((markup? fig) (second fig)) ;; fig: (<number-markup> "number") + (else fig)) + (if (null? alteration) + "" + (cond + ((= alteration DOUBLE-FLAT) "--") + ((= alteration FLAT) "-") + ((= alteration NATURAL) "!") + ((= alteration SHARP) "+") + ((= alteration DOUBLE-SHARP) "++") + (else ""))) + (if (null? bracket-stop) "" "]")))) (define-display-method LyricEvent (lyric parser) (format "~a~{~a~^ ~}" - (let ((text (ly:music-property lyric 'text))) - (if (or (string? text) - (eqv? (first text) simple-markup)) - ;; a string or a simple markup - (let ((string (if (string? text) - text - (second text)))) - (if (string-match "(\"| |[0-9])" string) - ;; TODO check exactly in which cases double quotes should be used - (format #f "~s" string) - string)) - (markup->lily-string text))) - (map-in-order (lambda (m) (music->lily-string m parser)) - (ly:music-property lyric 'articulations)))) + (let ((text (ly:music-property lyric 'text))) + (if (or (string? text) + (eqv? (first text) simple-markup)) + ;; a string or a simple markup + (let ((string (if (string? text) + text + (second text)))) + (if (string-match "(\"| |[0-9])" string) + ;; TODO check exactly in which cases double quotes should be used + (format #f "~s" string) + string)) + (markup->lily-string text))) + (map-in-order (lambda (m) (music->lily-string m parser)) + (ly:music-property lyric 'articulations)))) (define-display-method BreathingEvent (event parser) "\\breathe") @@ -649,33 +649,33 @@ Otherwise, return #f." (define-display-method AutoChangeMusic (m parser) (format #f "\\autochange ~a" - (music->lily-string (ly:music-property m 'element) parser))) + (music->lily-string (ly:music-property m 'element) parser))) (define-display-method ContextChange (m parser) (format #f "\\change ~a = \"~a\"" - (ly:music-property m 'change-to-type) - (ly:music-property m 'change-to-id))) + (ly:music-property m 'change-to-type) + (ly:music-property m 'change-to-id))) ;;; (define-display-method TimeScaledMusic (times parser) (let* ((num (ly:music-property times 'numerator)) - (den (ly:music-property times 'denominator)) + (den (ly:music-property times 'denominator)) (span (ly:music-property times 'duration #f)) ;; need to format before changing time scale (formatted-span (and span (duration->lily-string span #:force-duration #t))) - (scale (/ num den)) - (time-scale (*time-scale*))) + (scale (/ num den)) + (time-scale (*time-scale*))) (*previous-duration* #f) (let ((result (parameterize ((*force-line-break* #f) (*time-scale* (* time-scale scale))) - (format #f "\\tuplet ~a/~a ~@[~a ~]~a" - den - num - formatted-span - (music->lily-string (ly:music-property times 'element) parser))))) + (format #f "\\tuplet ~a/~a ~@[~a ~]~a" + den + num + formatted-span + (music->lily-string (ly:music-property times 'element) parser))))) (*previous-duration* #f) result))) @@ -694,16 +694,16 @@ Otherwise, return #f." (define (repeat->lily-string expr repeat-type parser) (let* ((main (music->lily-string (ly:music-property expr 'element) parser))) (format #f "\\repeat ~a ~a ~a ~a" - repeat-type - (ly:music-property expr 'repeat-count) - main - (let ((alternatives (ly:music-property expr 'elements))) - (if (null? alternatives) - "" - (format #f "\\alternative { ~{~a ~}}" - (map-in-order (lambda (music) - (music->lily-string music parser)) - alternatives))))))) + repeat-type + (ly:music-property expr 'repeat-count) + main + (let ((alternatives (ly:music-property expr 'elements))) + (if (null? alternatives) + "" + (format #f "\\alternative { ~{~a ~}}" + (map-in-order (lambda (music) + (music->lily-string music parser)) + alternatives))))))) (define-display-method VoltaRepeatedMusic (expr parser) (repeat->lily-string expr "volta" parser)) @@ -716,28 +716,28 @@ Otherwise, return #f." (define-display-method TremoloRepeatedMusic (expr parser) (let* ((main (ly:music-property expr 'element)) - (children (if (music-is-of-type? main 'sequential-music) - ;; \repeat tremolo n { ... } - (length (extract-named-music main '(EventChord - NoteEvent))) - ;; \repeat tremolo n c4 - 1)) - (times (ly:music-property expr 'repeat-count)) - - ;; # of dots is equal to the 1 in bitwise representation (minus 1)! - (dots (1- (logcount (* times children)))) - ;; The remaining missing multiplicator to scale the notes by - ;; times * children - (mult (/ (* times children (ash 1 dots)) (1- (ash 2 dots)))) - (shift (- (ly:intlog2 (floor mult))))) + (children (if (music-is-of-type? main 'sequential-music) + ;; \repeat tremolo n { ... } + (length (extract-named-music main '(EventChord + NoteEvent))) + ;; \repeat tremolo n c4 + 1)) + (times (ly:music-property expr 'repeat-count)) + + ;; # of dots is equal to the 1 in bitwise representation (minus 1)! + (dots (1- (logcount (* times children)))) + ;; The remaining missing multiplicator to scale the notes by + ;; times * children + (mult (/ (* times children (ash 1 dots)) (1- (ash 2 dots)))) + (shift (- (ly:intlog2 (floor mult))))) (set! main (ly:music-deep-copy main)) ;; Adjust the time of the notes (ly:music-compress main (ly:make-moment children 1)) ;; Adjust the displayed note durations (shift-duration-log main (- shift) (- dots)) (format #f "\\repeat tremolo ~a ~a" - times - (music->lily-string main parser)))) + times + (music->lily-string main parser)))) ;;; ;;; Contexts @@ -745,131 +745,131 @@ Otherwise, return #f." (define-display-method ContextSpeccedMusic (expr parser) (let ((id (ly:music-property expr 'context-id)) - (create-new (ly:music-property expr 'create-new)) - (music (ly:music-property expr 'element)) - (operations (ly:music-property expr 'property-operations)) - (ctype (ly:music-property expr 'context-type))) + (create-new (ly:music-property expr 'create-new)) + (music (ly:music-property expr 'element)) + (operations (ly:music-property expr 'property-operations)) + (ctype (ly:music-property expr 'context-type))) (format #f "~a ~a~a~a ~a" - (if (and (not (null? create-new)) create-new) - "\\new" - "\\context") - ctype - (if (null? id) - "" - (format #f " = ~s" id)) - (if (null? operations) - "" - (format #f " \\with {~{~a~}~%~v_}" - (parameterize ((*indent* (+ (*indent*) 2))) - (map (lambda (op) - (format #f "~%~v_\\~a ~s" - (*indent*) - (first op) - (second op))) - operations)) - (*indent*))) - (parameterize ((*current-context* ctype)) - (music->lily-string music parser))))) + (if (and (not (null? create-new)) create-new) + "\\new" + "\\context") + ctype + (if (null? id) + "" + (format #f " = ~s" id)) + (if (null? operations) + "" + (format #f " \\with {~{~a~}~%~v_}" + (parameterize ((*indent* (+ (*indent*) 2))) + (map (lambda (op) + (format #f "~%~v_\\~a ~s" + (*indent*) + (first op) + (second op))) + operations)) + (*indent*))) + (parameterize ((*current-context* ctype)) + (music->lily-string music parser))))) ;; special cases: \figures \lyrics \drums (define-extra-display-method ContextSpeccedMusic (expr parser) (with-music-match (expr (music 'ContextSpeccedMusic - create-new #t - property-operations ?op - context-type ?context-type - element ?sequence)) - (if (null? ?op) - (parameterize ((*explicit-mode* #f)) - (case ?context-type - ((FiguredBass) - (format #f "\\figures ~a" (music->lily-string ?sequence parser))) - ((Lyrics) - (format #f "\\lyrics ~a" (music->lily-string ?sequence parser))) - ((DrumStaff) - (format #f "\\drums ~a" (music->lily-string ?sequence parser))) - (else - #f))) - #f))) + create-new #t + property-operations ?op + context-type ?context-type + element ?sequence)) + (if (null? ?op) + (parameterize ((*explicit-mode* #f)) + (case ?context-type + ((FiguredBass) + (format #f "\\figures ~a" (music->lily-string ?sequence parser))) + ((Lyrics) + (format #f "\\lyrics ~a" (music->lily-string ?sequence parser))) + ((DrumStaff) + (format #f "\\drums ~a" (music->lily-string ?sequence parser))) + (else + #f))) + #f))) ;;; Context properties (define-extra-display-method ContextSpeccedMusic (expr parser) (let ((element (ly:music-property expr 'element)) - (property-tuning? (make-music-type-predicate 'PropertySet - 'PropertyUnset - 'OverrideProperty - 'RevertProperty)) - (sequence? (make-music-type-predicate 'SequentialMusic))) + (property-tuning? (make-music-type-predicate 'PropertySet + 'PropertyUnset + 'OverrideProperty + 'RevertProperty)) + (sequence? (make-music-type-predicate 'SequentialMusic))) (if (and (ly:music? element) - (or (property-tuning? element) - (and (sequence? element) - (every property-tuning? (ly:music-property element 'elements))))) - (parameterize ((*current-context* (ly:music-property expr 'context-type))) - (music->lily-string element parser)) - #f))) + (or (property-tuning? element) + (and (sequence? element) + (every property-tuning? (ly:music-property element 'elements))))) + (parameterize ((*current-context* (ly:music-property expr 'context-type))) + (music->lily-string element parser)) + #f))) (define (property-value->lily-string arg parser) (cond ((ly:music? arg) - (music->lily-string arg parser)) - ((string? arg) - (format #f "#~s" arg)) - ((markup? arg) - (markup->lily-string arg)) - (else - (format #f "#~a" (scheme-expr->lily-string arg))))) + (music->lily-string arg parser)) + ((string? arg) + (format #f "#~s" arg)) + ((markup? arg) + (markup->lily-string arg)) + (else + (format #f "#~a" (scheme-expr->lily-string arg))))) (define-display-method PropertySet (expr parser) (let ((property (ly:music-property expr 'symbol)) - (value (ly:music-property expr 'value)) - (once (ly:music-property expr 'once))) + (value (ly:music-property expr 'value)) + (once (ly:music-property expr 'once))) (format #f "~a\\set ~a~a = ~a~a" - (if (and (not (null? once))) - "\\once " - "") - (if (eqv? (*current-context*) 'Bottom) - "" - (format #f "~a . " (*current-context*))) - property - (property-value->lily-string value parser) - (new-line->lily-string)))) + (if (and (not (null? once))) + "\\once " + "") + (if (eqv? (*current-context*) 'Bottom) + "" + (format #f "~a . " (*current-context*))) + property + (property-value->lily-string value parser) + (new-line->lily-string)))) (define-display-method PropertyUnset (expr parser) (format #f "\\unset ~a~a~a" - (if (eqv? (*current-context*) 'Bottom) - "" - (format #f "~a . " (*current-context*))) - (ly:music-property expr 'symbol) - (new-line->lily-string))) + (if (eqv? (*current-context*) 'Bottom) + "" + (format #f "~a . " (*current-context*))) + (ly:music-property expr 'symbol) + (new-line->lily-string))) ;;; Layout properties (define-display-method OverrideProperty (expr parser) - (let* ((symbol (ly:music-property expr 'symbol)) - (properties (ly:music-property expr 'grob-property-path - (list (ly:music-property expr 'grob-property)))) - (value (ly:music-property expr 'grob-value)) - (once (ly:music-property expr 'once))) + (let* ((symbol (ly:music-property expr 'symbol)) + (properties (ly:music-property expr 'grob-property-path + (list (ly:music-property expr 'grob-property)))) + (value (ly:music-property expr 'grob-value)) + (once (ly:music-property expr 'once))) (format #f "~a\\override ~{~a~^.~} = ~a~a" - (if (or (null? once) - (not once)) - "" - "\\once ") + (if (or (null? once) + (not once)) + "" + "\\once ") (if (eqv? (*current-context*) 'Bottom) (cons symbol properties) (cons* (*current-context*) symbol properties)) (property-value->lily-string value parser) - (new-line->lily-string)))) + (new-line->lily-string)))) (define-display-method RevertProperty (expr parser) (let* ((symbol (ly:music-property expr 'symbol)) (properties (ly:music-property expr 'grob-property-path - (list (ly:music-property expr 'grob-property))))) + (list (ly:music-property expr 'grob-property))))) (format #f "\\revert ~{~a~^.~}~a" (if (eqv? (*current-context*) 'Bottom) (cons symbol properties) (cons* (*current-context*) symbol properties)) - (new-line->lily-string)))) + (new-line->lily-string)))) (define-display-method TimeSignatureMusic (expr parser) (let* ((num (ly:music-property expr 'numerator)) @@ -881,7 +881,7 @@ Otherwise, return #f." num den (new-line->lily-string)) (format #f - "\\time #'~a ~a/~a~a" + "\\time #'~a ~a/~a~a" structure num den (new-line->lily-string))))) @@ -889,43 +889,43 @@ Otherwise, return #f." (define-extra-display-method ContextSpeccedMusic (expr parser) "If expr is a melisma, return \"\\melisma\", otherwise, return #f." (with-music-match (expr (music 'ContextSpeccedMusic - element (music 'PropertySet - value #t - symbol 'melismaBusy))) - "\\melisma")) + element (music 'PropertySet + value #t + symbol 'melismaBusy))) + "\\melisma")) (define-extra-display-method ContextSpeccedMusic (expr parser) "If expr is a melisma end, return \"\\melismaEnd\", otherwise, return #f." (with-music-match (expr (music 'ContextSpeccedMusic - element (music 'PropertyUnset - symbol 'melismaBusy))) - "\\melismaEnd")) + element (music 'PropertyUnset + symbol 'melismaBusy))) + "\\melismaEnd")) ;;; \tempo (define-extra-display-method SequentialMusic (expr parser) (with-music-match (expr (music 'SequentialMusic - elements ((music 'TempoChangeEvent - text ?text - tempo-unit ?unit - metronome-count ?count) - (music 'ContextSpeccedMusic - element (music 'PropertySet - symbol 'tempoWholesPerMinute))))) - (format #f "\\tempo ~{~a~a~}~a = ~a~a" - (if (markup? ?text) - (list (markup->lily-string ?text) " ") - '()) - (duration->lily-string ?unit #:force-duration #t) - (if (pair? ?count) - (format #f "~a ~~ ~a" (car ?count) (cdr ?count)) - ?count) - (new-line->lily-string)))) + elements ((music 'TempoChangeEvent + text ?text + tempo-unit ?unit + metronome-count ?count) + (music 'ContextSpeccedMusic + element (music 'PropertySet + symbol 'tempoWholesPerMinute))))) + (format #f "\\tempo ~{~a~a~}~a = ~a~a" + (if (markup? ?text) + (list (markup->lily-string ?text) " ") + '()) + (duration->lily-string ?unit #:force-duration #t) + (if (pair? ?count) + (format #f "~a ~~ ~a" (car ?count) (cdr ?count)) + ?count) + (new-line->lily-string)))) (define-display-method TempoChangeEvent (expr parser) (let ((text (ly:music-property expr 'text))) (format #f "\\tempo ~a~a" - (markup->lily-string text) - (new-line->lily-string)))) + (markup->lily-string text) + (new-line->lily-string)))) ;;; \clef (define clef-name-alist #f) @@ -942,107 +942,107 @@ Otherwise, return #f." "If @var{expr} is a clef change, return \"\\clef ...\". Otherwise, return @code{#f}." (with-music-match (expr (music 'ContextSpeccedMusic - context-type 'Staff - element (music 'SequentialMusic - elements ((music 'PropertySet - value ?clef-glyph - symbol 'clefGlyph) - (music 'PropertySet - symbol 'middleCClefPosition) - (music 'PropertySet - value ?clef-position - symbol 'clefPosition) - (music 'PropertySet - value ?clef-transposition - symbol 'clefTransposition) - (music 'ApplyContext - procedure ly:set-middle-C!))))) - (let ((clef-name (assoc-get (list ?clef-glyph ?clef-position 0) - clef-name-alist))) - (if clef-name - (format #f "\\clef \"~a~{~a~a~}\"~a" - clef-name - (cond ((= 0 ?clef-transposition) - (list "" "")) - ((> ?clef-transposition 0) - (list "^" (1+ ?clef-transposition))) - (else - (list "_" (- 1 ?clef-transposition)))) - (new-line->lily-string)) - #f)))) + context-type 'Staff + element (music 'SequentialMusic + elements ((music 'PropertySet + value ?clef-glyph + symbol 'clefGlyph) + (music 'PropertySet + symbol 'middleCClefPosition) + (music 'PropertySet + value ?clef-position + symbol 'clefPosition) + (music 'PropertySet + value ?clef-transposition + symbol 'clefTransposition) + (music 'ApplyContext + procedure ly:set-middle-C!))))) + (let ((clef-name (assoc-get (list ?clef-glyph ?clef-position 0) + clef-name-alist))) + (if clef-name + (format #f "\\clef \"~a~{~a~a~}\"~a" + clef-name + (cond ((= 0 ?clef-transposition) + (list "" "")) + ((> ?clef-transposition 0) + (list "^" (1+ ?clef-transposition))) + (else + (list "_" (- 1 ?clef-transposition)))) + (new-line->lily-string)) + #f)))) ;;; \bar (define-extra-display-method ContextSpeccedMusic (expr parser) "If `expr' is a bar, return \"\\bar ...\". Otherwise, return #f." (with-music-match (expr (music 'ContextSpeccedMusic - context-type 'Timing - element (music 'PropertySet - value ?bar-type - symbol 'whichBar))) - (format #f "\\bar \"~a\"~a" ?bar-type (new-line->lily-string)))) + context-type 'Timing + element (music 'PropertySet + value ?bar-type + symbol 'whichBar))) + (format #f "\\bar \"~a\"~a" ?bar-type (new-line->lily-string)))) ;;; \partial (define-extra-display-method ContextSpeccedMusic (expr parser) "If `expr' is a partial measure, return \"\\partial ...\". Otherwise, return #f." (with-music-match (expr (music - 'ContextSpeccedMusic - element (music - 'ContextSpeccedMusic - context-type 'Timing - element (music - 'PartialSet - partial-duration ?duration)))) - - (and ?duration - (format #f "\\partial ~a" - (duration->lily-string ?duration #:force-duration #t))))) + 'ContextSpeccedMusic + element (music + 'ContextSpeccedMusic + context-type 'Timing + element (music + 'PartialSet + partial-duration ?duration)))) + + (and ?duration + (format #f "\\partial ~a" + (duration->lily-string ?duration #:force-duration #t))))) ;;; ;;; (define-display-method ApplyOutputEvent (applyoutput parser) (let ((proc (ly:music-property applyoutput 'procedure)) - (ctx (ly:music-property applyoutput 'context-type))) + (ctx (ly:music-property applyoutput 'context-type))) (format #f "\\applyOutput #'~a #~a" - ctx - (or (procedure-name proc) - (with-output-to-string - (lambda () - (pretty-print (procedure-source proc)))))))) + ctx + (or (procedure-name proc) + (with-output-to-string + (lambda () + (pretty-print (procedure-source proc)))))))) (define-display-method ApplyContext (applycontext parser) (let ((proc (ly:music-property applycontext 'procedure))) (format #f "\\applyContext #~a" - (or (procedure-name proc) - (with-output-to-string - (lambda () - (pretty-print (procedure-source proc)))))))) + (or (procedure-name proc) + (with-output-to-string + (lambda () + (pretty-print (procedure-source proc)))))))) ;;; \partcombine (define-display-method PartCombineMusic (expr parser) (format #f "\\partcombine ~{~a ~}" - (map-in-order (lambda (music) - (music->lily-string music parser)) - (ly:music-property expr 'elements)))) + (map-in-order (lambda (music) + (music->lily-string music parser)) + (ly:music-property expr 'elements)))) (define-extra-display-method PartCombineMusic (expr parser) (with-music-match (expr (music 'PartCombineMusic - elements ((music 'UnrelativableMusic - element (music 'ContextSpeccedMusic - context-id "one" - context-type 'Voice - element ?sequence1)) - (music 'UnrelativableMusic - element (music 'ContextSpeccedMusic - context-id "two" - context-type 'Voice - element ?sequence2))))) - (format #f "\\partcombine ~a~a~a" - (music->lily-string ?sequence1 parser) - (new-line->lily-string) - (music->lily-string ?sequence2 parser)))) + elements ((music 'UnrelativableMusic + element (music 'ContextSpeccedMusic + context-id "one" + context-type 'Voice + element ?sequence1)) + (music 'UnrelativableMusic + element (music 'ContextSpeccedMusic + context-id "two" + context-type 'Voice + element ?sequence2))))) + (format #f "\\partcombine ~a~a~a" + (music->lily-string ?sequence1 parser) + (new-line->lily-string) + (music->lily-string ?sequence2 parser)))) (define-display-method UnrelativableMusic (expr parser) (music->lily-string (ly:music-property expr 'element) parser)) @@ -1050,19 +1050,19 @@ Otherwise, return #f." ;;; Cue notes (define-display-method QuoteMusic (expr parser) (or (with-music-match (expr (music - 'QuoteMusic - quoted-voice-direction ?quoted-voice-direction - quoted-music-name ?quoted-music-name - quoted-context-id "cue" - quoted-context-type 'Voice - element ?music)) - (format #f "\\cueDuring #~s #~a ~a" - ?quoted-music-name - ?quoted-voice-direction - (music->lily-string ?music parser))) + 'QuoteMusic + quoted-voice-direction ?quoted-voice-direction + quoted-music-name ?quoted-music-name + quoted-context-id "cue" + quoted-context-type 'Voice + element ?music)) + (format #f "\\cueDuring #~s #~a ~a" + ?quoted-music-name + ?quoted-voice-direction + (music->lily-string ?music parser))) (format #f "\\quoteDuring #~s ~a" - (ly:music-property expr 'quoted-music-name) - (music->lily-string (ly:music-property expr 'element) parser)))) + (ly:music-property expr 'quoted-music-name) + (music->lily-string (ly:music-property expr 'element) parser)))) ;;; ;;; Breaks @@ -1084,21 +1084,21 @@ Otherwise, return #f." (define-extra-display-method EventChord (expr parser) (with-music-match (expr (music 'EventChord - elements ((music 'LineBreakEvent - break-permission 'force) - (music 'PageBreakEvent - break-permission 'force)))) - "\\pageBreak")) + elements ((music 'LineBreakEvent + break-permission 'force) + (music 'PageBreakEvent + break-permission 'force)))) + "\\pageBreak")) (define-extra-display-method EventChord (expr parser) (with-music-match (expr (music 'EventChord - elements ((music 'LineBreakEvent - break-permission 'force) - (music 'PageBreakEvent - break-permission 'force) - (music 'PageTurnEvent - break-permission 'force)))) - "\\pageTurn")) + elements ((music 'LineBreakEvent + break-permission 'force) + (music 'PageBreakEvent + break-permission 'force) + (music 'PageTurnEvent + break-permission 'force)))) + "\\pageTurn")) ;;; ;;; Lyrics @@ -1107,30 +1107,30 @@ Otherwise, return #f." ;;; \lyricsto (define-display-method LyricCombineMusic (expr parser) (format #f "\\lyricsto ~s ~a" - (ly:music-property expr 'associated-context) - (parameterize ((*explicit-mode* #f)) - (music->lily-string (ly:music-property expr 'element) parser)))) + (ly:music-property expr 'associated-context) + (parameterize ((*explicit-mode* #f)) + (music->lily-string (ly:music-property expr 'element) parser)))) ;; \addlyrics (define-extra-display-method SimultaneousMusic (expr parser) (with-music-match (expr (music 'SimultaneousMusic - elements ((music 'ContextSpeccedMusic - context-id ?id - context-type 'Voice - element ?note-sequence) - (music 'ContextSpeccedMusic - context-type 'Lyrics - create-new #t - element (music 'LyricCombineMusic - associated-context ?associated-id - element ?lyric-sequence))))) - (if (string=? ?id ?associated-id) - (format #f "~a~a \\addlyrics ~a" - (music->lily-string ?note-sequence parser) - (new-line->lily-string) - (parameterize ((*explicit-mode* #f)) - (music->lily-string ?lyric-sequence parser))) - #f))) + elements ((music 'ContextSpeccedMusic + context-id ?id + context-type 'Voice + element ?note-sequence) + (music 'ContextSpeccedMusic + context-type 'Lyrics + create-new #t + element (music 'LyricCombineMusic + associated-context ?associated-id + element ?lyric-sequence))))) + (if (string=? ?id ?associated-id) + (format #f "~a~a \\addlyrics ~a" + (music->lily-string ?note-sequence parser) + (new-line->lily-string) + (parameterize ((*explicit-mode* #f)) + (music->lily-string ?lyric-sequence parser))) + #f))) ;; Silence internal event sent at end of each lyrics block (define-display-method CompletizeExtenderEvent (expr parser) diff --git a/scm/define-music-properties.scm b/scm/define-music-properties.scm index dbad0cf092..c796323c67 100644 --- a/scm/define-music-properties.scm +++ b/scm/define-music-properties.scm @@ -28,7 +28,7 @@ (lambda (x) (apply music-property-description x)) `( (absolute-octave ,integer? - "The absolute octave for a octave check note.") + "The absolute octave for a octave check note.") (alteration ,number? "Alteration for figured bass.") (alternative-dir ,ly:dir? "Indicates if an AlternativeMusic is the First (-1), Middle (0), or Last (1) of group of alternate endings.") @@ -38,7 +38,7 @@ lettering should be incremented.") TODO: Consider making type into symbol.") (articulations ,ly:music-list? - "Articulation events specifically for this note.") + "Articulation events specifically for this note.") (associated-context ,string? "Name of the Voice context associated with this @code{\\lyricsto} section.") (augmented ,boolean? "This figure is for an augmented figured bass @@ -58,7 +58,7 @@ TODO: Use SpanEvents?") (bracket-stop ,boolean? "Stop a bracket here.") (break-penalty ,number? "Penalty for line break hint.") (break-permission ,symbol? - "Whether to allow, forbid or force a line break.") + "Whether to allow, forbid or force a line break.") (cautionary ,boolean? "If set, this alteration needs a cautionary accidental.") @@ -89,7 +89,7 @@ simultaneous music, or the alternatives of repeated music.") (elements-callback ,procedure? "Return a list of children, for use by a sequential iterator. Takes a single music parameter.") (error-found ,boolean? - "If true, a parsing error was found in this expression.") + "If true, a parsing error was found in this expression.") (events ,list? "A list of events contained in this event.") (figure ,integer? "A bass figure.") @@ -220,8 +220,8 @@ repeat element list.") FIXME: Naming.") (X-offset ,number? - "Offset of resulting grob; only used for balloon texts.") + "Offset of resulting grob; only used for balloon texts.") - (Y-offset ,number? - "Offset of resulting grob; only used for balloon texts.") - ))) +(Y-offset ,number? + "Offset of resulting grob; only used for balloon texts.") +))) diff --git a/scm/define-music-types.scm b/scm/define-music-types.scm index e9c06e77d5..5cc5907fbc 100644 --- a/scm/define-music-types.scm +++ b/scm/define-music-types.scm @@ -1,7 +1,7 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; ;;;; Copyright (C) 1998--2012 Han-Wen Nienhuys <hanwen@xs4all.nl> -;;;; Jan Nieuwenhuizen <janneke@gnu.org> +;;;; Jan Nieuwenhuizen <janneke@gnu.org> ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -29,25 +29,25 @@ Syntax: @var{note}@code{\\x}, where @code{\\x} is a dynamic mark like @code{\\ppp} or @code{\\sfz}. A complete list is in file @file{ly/@/dynamic-scripts-init.ly}.") - (types . (general-music post-event event dynamic-event absolute-dynamic-event)) - )) + (types . (general-music post-event event dynamic-event absolute-dynamic-event)) + )) (AlternativeEvent . ((description . "Create a alternative event.") (types . (general-music event alternative-event)) - )) + )) (AnnotateOutputEvent . ((description . "Print an annotation of an output element.") - (types . (general-music event annotate-output-event post-event)) - )) + (types . (general-music event annotate-output-event post-event)) + )) (ApplyContext . ((description . "Call the argument with the current context during interpreting phase.") - (types . (general-music apply-context)) - (iterator-ctor . ,ly:apply-context-iterator::constructor) - )) + (types . (general-music apply-context)) + (iterator-ctor . ,ly:apply-context-iterator::constructor) + )) (ApplyOutputEvent . ((description . "Call the argument with all current grobs during @@ -57,15 +57,15 @@ Syntax: @code{\\applyOutput #'@var{context} @var{func}} Arguments to @var{func} are 1.@tie{}the grob, 2.@tie{}the originating context, and 3.@tie{}the context where @var{func} is called.") - (types . (general-music event apply-output-event)) - )) + (types . (general-music event apply-output-event)) + )) (ArpeggioEvent . ((description . "Make an arpeggio on this note. Syntax: @w{@var{note}@code{-\\arpeggio}}") - (types . (general-music post-event arpeggio-event event)) - )) + (types . (general-music post-event arpeggio-event event)) + )) ;; todo: use articulation-event for slur as well. ;; separate non articulation scripts @@ -77,90 +77,90 @@ Syntax: @var{note}@code{x}@code{y}, where @code{x} is a direction\ \n(no direction specified), and where @code{y} is an articulation\ \n(such as @w{@code{-.}}, @w{@code{->}}, @code{\\tenuto}, @code{\\downbow}). See the Notation Reference for details.") - (types . (general-music post-event event articulation-event script-event)) - )) + (types . (general-music post-event event articulation-event script-event)) + )) (AutoChangeMusic . ((description . "Used for making voices that switch between piano staves automatically.") - (iterator-ctor . ,ly:auto-change-iterator::constructor) - (start-callback . ,ly:music-wrapper::start-callback) - (length-callback . ,ly:music-wrapper::length-callback) - (types . (general-music music-wrapper-music auto-change-instruction)) - )) + (iterator-ctor . ,ly:auto-change-iterator::constructor) + (start-callback . ,ly:music-wrapper::start-callback) + (length-callback . ,ly:music-wrapper::length-callback) + (types . (general-music music-wrapper-music auto-change-instruction)) + )) (BarCheck . ((description . "Check whether this music coincides with the start of the measure.") - (types . (general-music bar-check)) - (iterator-ctor . ,ly:bar-check-iterator::constructor) - )) + (types . (general-music bar-check)) + (iterator-ctor . ,ly:bar-check-iterator::constructor) + )) (BassFigureEvent . ((description . "Print a bass-figure text.") - (types . (general-music event rhythmic-event bass-figure-event)) - )) + (types . (general-music event rhythmic-event bass-figure-event)) + )) (BeamEvent . ((description . "Start or stop a beam. Syntax for manual control: @code{c8-[ c c-] c8}") - (types . (general-music post-event event beam-event span-event)) - )) + (types . (general-music post-event event beam-event span-event)) + )) (BeamForbidEvent . ((description . "Specify that a note may not auto-beamed.") - (types . (general-music post-event event beam-forbid-event)) - )) + (types . (general-music post-event event beam-forbid-event)) + )) (BreakDynamicSpanEvent . ((description . "End an alignment spanner for dynamics here.") - (types . (general-music post-event break-span-event break-dynamic-span-event event)) - )) + (types . (general-music post-event break-span-event break-dynamic-span-event event)) + )) (BendAfterEvent . ((description . "A drop/@/fall/@/doit jazz articulation.") - (types . (general-music post-event bend-after-event event)))) + (types . (general-music post-event bend-after-event event)))) (BreathingEvent . ((description . "Create a @q{breath mark} or @q{comma}. Syntax: @var{note}@code{\\breathe}") - (types . (general-music event breathing-event)) - )) + (types . (general-music event breathing-event)) + )) (ClusterNoteEvent . ((description . "A note that is part of a cluster.") - ;; not a note-event, to ensure that Note_heads_engraver doesn't eat it. - (iterator-ctor . ,ly:rhythmic-music-iterator::constructor) - (types . (general-music cluster-note-event melodic-event - rhythmic-event event)) - )) + ;; not a note-event, to ensure that Note_heads_engraver doesn't eat it. + (iterator-ctor . ,ly:rhythmic-music-iterator::constructor) + (types . (general-music cluster-note-event melodic-event + rhythmic-event event)) + )) (CompletizeExtenderEvent . ((description . "Used internally to signal the end of a lyrics block to ensure extenders are completed correctly when a @code{Lyrics} context ends before its associated @code{Voice} context.") - (types . (general-music completize-extender-event event)) - )) + (types . (general-music completize-extender-event event)) + )) (ContextChange . ((description . "Change staves in Piano staff. Syntax: @code{\\change Staff = @var{new-id}}") - (iterator-ctor . ,ly:change-iterator::constructor) - (types . (general-music translator-change-instruction)) - )) + (iterator-ctor . ,ly:change-iterator::constructor) + (types . (general-music translator-change-instruction)) + )) (ContextSpeccedMusic . ((description . "Interpret the argument music within a specific context.") - (iterator-ctor . ,ly:context-specced-music-iterator::constructor) - (length-callback . ,ly:music-wrapper::length-callback) - (start-callback . ,ly:music-wrapper::start-callback) - (types . (context-specification general-music music-wrapper-music)) - )) + (iterator-ctor . ,ly:context-specced-music-iterator::constructor) + (length-callback . ,ly:music-wrapper::length-callback) + (start-callback . ,ly:music-wrapper::start-callback) + (types . (context-specification general-music music-wrapper-music)) + )) (CrescendoEvent . ((description . "Begin or end a crescendo. @@ -169,9 +169,9 @@ Syntax: @var{note}@code{\\<} @dots{} @var{note}@code{\\!} An alternative syntax is @var{note}@code{\\cr} @dots{} @var{note}@code{\\endcr}.") - (types . (general-music post-event span-event span-dynamic-event crescendo-event - event)) - )) + (types . (general-music post-event span-event span-dynamic-event crescendo-event + event)) + )) (DecrescendoEvent . ((description . "Begin or end a decrescendo. @@ -180,24 +180,24 @@ Syntax: @var{note}@code{\\>} @dots{} @var{note}@code{\\!} An alternative syntax is @var{note}@code{\\decr} @dots{} @var{note}@code{\\enddecr}.") - (types . (general-music post-event span-event span-dynamic-event decrescendo-event - event)) - )) + (types . (general-music post-event span-event span-dynamic-event decrescendo-event + event)) + )) (DoublePercentEvent . ((description . "Used internally to signal double percent repeats.") - (types . (general-music event double-percent-event rhythmic-event)) - )) + (types . (general-music event double-percent-event rhythmic-event)) + )) (EpisemaEvent . ((description . "Begin or end an episema.") - (types . (general-music post-event span-event event episema-event)) - )) + (types . (general-music post-event span-event event episema-event)) + )) (Event . ((description . "Atomic music event.") - (types . (general-music event)) - )) + (types . (general-music event)) + )) (EventChord . ((description . "Explicitly entered chords. @@ -209,96 +209,96 @@ attached by the parser just follow any rhythmic events in An unexpanded chord repetition @samp{q} is recognizable by having its duration stored in @code{duration}.") - (iterator-ctor . ,ly:event-chord-iterator::constructor) - (length-callback . ,ly:music-sequence::event-chord-length-callback) - (to-relative-callback . - ,ly:music-sequence::event-chord-relative-callback) - (types . (general-music event-chord simultaneous-music)) - )) + (iterator-ctor . ,ly:event-chord-iterator::constructor) + (length-callback . ,ly:music-sequence::event-chord-length-callback) + (to-relative-callback . + ,ly:music-sequence::event-chord-relative-callback) + (types . (general-music event-chord simultaneous-music)) + )) (ExtenderEvent . ((description . "Extend lyrics.") - (types . (general-music post-event extender-event event)) - )) + (types . (general-music post-event extender-event event)) + )) (FingeringEvent . ((description . "Specify what finger to use for this note.") - (types . (general-music post-event fingering-event event)) - )) + (types . (general-music post-event fingering-event event)) + )) (FootnoteEvent . ((description . "Footnote a grob.") - (types . (general-music event footnote-event)) - )) + (types . (general-music event footnote-event)) + )) (GlissandoEvent . ((description . "Start a glissando on this note.") - (types . (general-music post-event glissando-event event)) - )) + (types . (general-music post-event glissando-event event)) + )) (GraceMusic . ((description . "Interpret the argument as grace notes.") - (start-callback . ,ly:grace-music::start-callback) - (length . ,ZERO-MOMENT) - (iterator-ctor . ,ly:grace-iterator::constructor) - (types . (grace-music music-wrapper-music general-music)) - )) + (start-callback . ,ly:grace-music::start-callback) + (length . ,ZERO-MOMENT) + (iterator-ctor . ,ly:grace-iterator::constructor) + (types . (grace-music music-wrapper-music general-music)) + )) (HarmonicEvent . ((description . "Mark a note as harmonic.") - (types . (general-music post-event event harmonic-event)) - )) + (types . (general-music post-event event harmonic-event)) + )) (HyphenEvent . ((description . "A hyphen between lyric syllables.") - (types . (general-music post-event hyphen-event event)) - )) + (types . (general-music post-event hyphen-event event)) + )) (KeyChangeEvent . ((description . "Change the key signature. Syntax: @code{\\key} @var{name} @var{scale}") - (to-relative-callback . ,(lambda (x p) p)) - (types . (general-music key-change-event event)) - )) + (to-relative-callback . ,(lambda (x p) p)) + (types . (general-music key-change-event event)) + )) (LabelEvent . ((description . "Place a bookmarking label.") - (types . (general-music label-event event)) - )) + (types . (general-music label-event event)) + )) (LaissezVibrerEvent . ((description . "Don't damp this chord. Syntax: @var{note}@code{\\laissezVibrer}") - (types . (general-music post-event event laissez-vibrer-event)) - )) + (types . (general-music post-event event laissez-vibrer-event)) + )) (LigatureEvent . ((description . "Start or end a ligature.") - (types . (general-music span-event ligature-event event)) - )) + (types . (general-music span-event ligature-event event)) + )) (LineBreakEvent . ((description . "Allow, forbid or force a line break.") - (types . (general-music line-break-event break-event event)) - )) + (types . (general-music line-break-event break-event event)) + )) (LyricCombineMusic . ((description . "Align lyrics to the start of notes. Syntax: @code{\\lyricsto} @var{voicename} @var{lyrics}") - (length . ,ZERO-MOMENT) - (types . (general-music lyric-combine-music)) - (iterator-ctor . ,ly:lyric-combine-music-iterator::constructor) - )) + (length . ,ZERO-MOMENT) + (types . (general-music lyric-combine-music)) + (iterator-ctor . ,ly:lyric-combine-music-iterator::constructor) + )) (LyricEvent . ((description . "A lyric syllable. Must be entered in lyrics mode, i.e., @code{\\lyrics @{ twinkle4 twinkle4 @} }.") - (iterator-ctor . ,ly:rhythmic-music-iterator::constructor) - (types . (general-music rhythmic-event lyric-event event)) - )) + (iterator-ctor . ,ly:rhythmic-music-iterator::constructor) + (types . (general-music rhythmic-event lyric-event event)) + )) (MarkEvent . ((description . "Insert a rehearsal mark. @@ -306,8 +306,8 @@ i.e., @code{\\lyrics @{ twinkle4 twinkle4 @} }.") Syntax: @code{\\mark} @var{marker} Example: @code{\\mark \"A\"}") - (types . (general-music mark-event event)) - )) + (types . (general-music mark-event event)) + )) (MeasureCounterEvent . ((description . "Used to signal the start and end of a measure count.") @@ -317,18 +317,18 @@ Example: @code{\\mark \"A\"}") (MultiMeasureRestEvent . ((description . "Used internally by @code{MultiMeasureRestMusic} to signal rests.") - (types . (general-music event rhythmic-event - multi-measure-rest-event)) - )) + (types . (general-music event rhythmic-event + multi-measure-rest-event)) + )) (MultiMeasureRestMusic . ((description . "Rests that may be compressed into Multi rests. Syntax: @code{R2.*4} for 4 measures in 3/4 time.") - (iterator-ctor . ,ly:sequential-iterator::constructor) - (elements-callback . ,mm-rest-child-list) - (types . (general-music multi-measure-rest)) - )) + (iterator-ctor . ,ly:sequential-iterator::constructor) + (elements-callback . ,mm-rest-child-list) + (types . (general-music multi-measure-rest)) + )) (MultiMeasureTextEvent . ((description . "Texts on multi measure rests. @@ -336,13 +336,13 @@ Syntax: @code{R2.*4} for 4 measures in 3/4 time.") Syntax: @code{R-\\markup @{ \\roman \"bla\" @}} Note the explicit font switch.") - (types . (general-music post-event event multi-measure-text-event)) - )) + (types . (general-music post-event event multi-measure-text-event)) + )) (Music . ((description . "Generic type for music expressions.") - (types . (general-music)) - )) + (types . (general-music)) + )) (NoteEvent . ((description . "A note. @@ -351,91 +351,91 @@ Outside of chords, any events in @code{articulations} with a listener are broadcast like chord articulations, the others are retained. For iteration inside of chords, @xref{EventChord}.") - (iterator-ctor . ,ly:rhythmic-music-iterator::constructor) - (types . (general-music event note-event rhythmic-event - melodic-event)) - )) + (iterator-ctor . ,ly:rhythmic-music-iterator::constructor) + (types . (general-music event note-event rhythmic-event + melodic-event)) + )) (NoteGroupingEvent . ((description . "Start or stop grouping brackets.") - (types . (general-music post-event event note-grouping-event)) - )) + (types . (general-music post-event event note-grouping-event)) + )) (OttavaMusic . ((description . "Start or stop an ottava bracket.") - (iterator-ctor . ,ly:sequential-iterator::constructor) - (elements-callback . ,make-ottava-set) - (types . (general-music ottava-music)) - )) + (iterator-ctor . ,ly:sequential-iterator::constructor) + (elements-callback . ,make-ottava-set) + (types . (general-music ottava-music)) + )) (OverrideProperty . ((description . "Extend the definition of a graphical object. Syntax: @code{\\override} [ @var{context} @code{.} ] @var{object} @var{property} @code{=} @var{value}") - (types . (general-music layout-instruction-event - override-property-event)) - (iterator-ctor . ,ly:push-property-iterator::constructor) - (untransposable . #t) - )) + (types . (general-music layout-instruction-event + override-property-event)) + (iterator-ctor . ,ly:push-property-iterator::constructor) + (untransposable . #t) + )) (PageBreakEvent . ((description . "Allow, forbid or force a page break.") - (types . (general-music break-event page-break-event event)) - )) + (types . (general-music break-event page-break-event event)) + )) (PageTurnEvent . ((description . "Allow, forbid or force a page turn.") - (types . (general-music break-event page-turn-event event)) - )) + (types . (general-music break-event page-turn-event event)) + )) (PartCombineForceEvent . ((description . "Override the part-combiner's strategy.") - (types . (general-music part-combine-force-event event)) - )) + (types . (general-music part-combine-force-event event)) + )) (PartialSet . ((description . "Create an anacrusis or upbeat (partial measure).") - (iterator-ctor . ,ly:partial-iterator::constructor) - (types . (general-music partial-set)) + (iterator-ctor . ,ly:partial-iterator::constructor) + (types . (general-music partial-set)) )) (PartCombineMusic . ((description . "Combine two parts on a staff, either merged or as separate voices.") - (length-callback . ,ly:music-sequence::maximum-length-callback) - (start-callback . ,ly:music-sequence::minimum-start-callback) - (types . (general-music part-combine-music)) - (iterator-ctor . ,ly:part-combine-iterator::constructor) - )) + (length-callback . ,ly:music-sequence::maximum-length-callback) + (start-callback . ,ly:music-sequence::minimum-start-callback) + (types . (general-music part-combine-music)) + (iterator-ctor . ,ly:part-combine-iterator::constructor) + )) (PercentEvent . ((description . "Used internally to signal percent repeats.") - (types . (general-music event percent-event rhythmic-event)) - )) + (types . (general-music event percent-event rhythmic-event)) + )) (PercentRepeatedMusic . ((description . "Repeats encoded by percents and slashes.") - (iterator-ctor . ,ly:percent-repeat-iterator::constructor) - (start-callback . ,ly:repeated-music::first-start) - (length-callback . ,ly:repeated-music::unfolded-music-length) - (types . (general-music repeated-music percent-repeated-music)) - )) + (iterator-ctor . ,ly:percent-repeat-iterator::constructor) + (start-callback . ,ly:repeated-music::first-start) + (length-callback . ,ly:repeated-music::unfolded-music-length) + (types . (general-music repeated-music percent-repeated-music)) + )) (PesOrFlexaEvent . ((description . "Within a ligature, mark the previous and the following note to form a pes (if melody goes up) or a flexa (if melody goes down).") - (types . (general-music pes-or-flexa-event event)) - )) + (types . (general-music pes-or-flexa-event event)) + )) (PhrasingSlurEvent . ((description . "Start or end phrasing slur. Syntax: @var{note}@code{\\(} and @var{note}@code{\\)}") (spanner-id . "") - (types . (general-music post-event span-event event phrasing-slur-event)) - )) + (types . (general-music post-event span-event event phrasing-slur-event)) + )) (PostEvents . ((description . "Container for several postevents. @@ -447,212 +447,212 @@ This can be used to package several events into a single one. Should not be see . ((description . "Set a context property. Syntax: @code{\\set @var{context}.@var{prop} = @var{scheme-val}}") - (types . (layout-instruction-event general-music)) - (iterator-ctor . ,ly:property-iterator::constructor) - (untransposable . #t) - )) + (types . (layout-instruction-event general-music)) + (iterator-ctor . ,ly:property-iterator::constructor) + (untransposable . #t) + )) (PropertyUnset . ((description . "Restore the default setting for a context property. See @ref{PropertySet}. Syntax: @code{\\unset @var{context}.@var{prop}}") - (types . (layout-instruction-event general-music)) - (iterator-ctor . ,ly:property-unset-iterator::constructor) - )) + (types . (layout-instruction-event general-music)) + (iterator-ctor . ,ly:property-unset-iterator::constructor) + )) (QuoteMusic . ((description . "Quote preprocessed snippets of music.") - (iterator-ctor . ,ly:music-wrapper-iterator::constructor) - (length-callback . ,ly:music-wrapper::length-callback) - (start-callback . ,ly:music-wrapper::start-callback) - (types . (general-music music-wrapper-music)) - )) + (iterator-ctor . ,ly:music-wrapper-iterator::constructor) + (length-callback . ,ly:music-wrapper::length-callback) + (start-callback . ,ly:music-wrapper::start-callback) + (types . (general-music music-wrapper-music)) + )) (RelativeOctaveCheck . ((description . "Check if a pitch is in the correct octave.") - (to-relative-callback . ,ly:relative-octave-check::relative-callback) - (types . (general-music relative-octave-check)) - )) + (to-relative-callback . ,ly:relative-octave-check::relative-callback) + (types . (general-music relative-octave-check)) + )) (RelativeOctaveMusic . ((description . "Music that was entered in relative octave notation.") - (to-relative-callback . ,ly:relative-octave-music::relative-callback) - (iterator-ctor . ,ly:music-wrapper-iterator::constructor) - (length-callback . ,ly:music-wrapper::length-callback) - (start-callback . ,ly:music-wrapper::start-callback) - (types . (music-wrapper-music general-music relative-octave-music)) - )) + (to-relative-callback . ,ly:relative-octave-music::relative-callback) + (iterator-ctor . ,ly:music-wrapper-iterator::constructor) + (length-callback . ,ly:music-wrapper::length-callback) + (start-callback . ,ly:music-wrapper::start-callback) + (types . (music-wrapper-music general-music relative-octave-music)) + )) (RepeatedMusic . ((description . "Repeat music in different ways.") - (types . (general-music repeated-music)) - )) + (types . (general-music repeated-music)) + )) (RepeatSlashEvent . ((description . "Used internally to signal beat repeats.") - (types . (general-music event repeat-slash-event rhythmic-event)) - )) + (types . (general-music event repeat-slash-event rhythmic-event)) + )) (RepeatTieEvent . ((description . "Ties for starting a second volta bracket.") - (types . (general-music post-event event repeat-tie-event)) - )) + (types . (general-music post-event event repeat-tie-event)) + )) (RestEvent . ((description . "A Rest. Syntax: @code{r4} for a quarter rest.") - (iterator-ctor . ,ly:rhythmic-music-iterator::constructor) - (types . (general-music event rhythmic-event rest-event)) - )) + (iterator-ctor . ,ly:rhythmic-music-iterator::constructor) + (types . (general-music event rhythmic-event rest-event)) + )) (RevertProperty . ((description . "The opposite of @ref{OverrideProperty}: remove a previously added property from a graphical object definition.") - (types . (general-music layout-instruction-event)) - (iterator-ctor . ,ly:pop-property-iterator::constructor) - )) + (types . (general-music layout-instruction-event)) + (iterator-ctor . ,ly:pop-property-iterator::constructor) + )) (ScriptEvent . ((description . "Add an articulation mark to a note.") - (types . (general-music event)) - )) + (types . (general-music event)) + )) (SequentialMusic . ((description . "Music expressions concatenated. Syntax: @code{\\sequential @{ @dots{} @}} or simply @code{@{ @dots{} @}}") - (length-callback . ,ly:music-sequence::cumulative-length-callback) - (start-callback . ,ly:music-sequence::first-start-callback) - (elements-callback . ,(lambda (m) (ly:music-property m 'elements))) - (iterator-ctor . ,ly:sequential-iterator::constructor) - (types . (general-music sequential-music)) - )) + (length-callback . ,ly:music-sequence::cumulative-length-callback) + (start-callback . ,ly:music-sequence::first-start-callback) + (elements-callback . ,(lambda (m) (ly:music-property m 'elements))) + (iterator-ctor . ,ly:sequential-iterator::constructor) + (types . (general-music sequential-music)) + )) (SimultaneousMusic . ((description . "Music playing together. Syntax: @code{\\simultaneous @{ @dots{} @}} or @code{<< @dots{} >>}") - (iterator-ctor . ,ly:simultaneous-music-iterator::constructor) - (start-callback . ,ly:music-sequence::minimum-start-callback) - (length-callback . ,ly:music-sequence::maximum-length-callback) - (to-relative-callback . - ,ly:music-sequence::simultaneous-relative-callback) - (types . (general-music simultaneous-music)) - )) + (iterator-ctor . ,ly:simultaneous-music-iterator::constructor) + (start-callback . ,ly:music-sequence::minimum-start-callback) + (length-callback . ,ly:music-sequence::maximum-length-callback) + (to-relative-callback . + ,ly:music-sequence::simultaneous-relative-callback) + (types . (general-music simultaneous-music)) + )) (SkipEvent . ((description . "Filler that takes up duration, but does not print anything. Syntax: @code{s4} for a skip equivalent to a quarter rest.") - (iterator-ctor . ,ly:rhythmic-music-iterator::constructor) - (types . (general-music event rhythmic-event skip-event)) - )) + (iterator-ctor . ,ly:rhythmic-music-iterator::constructor) + (types . (general-music event rhythmic-event skip-event)) + )) (SkipMusic . ((description . "Filler that takes up duration, does not print anything, and also does not create staves or voices implicitly. Syntax: @code{\\skip} @var{duration}") - (length-callback . ,ly:music-duration-length) - (iterator-ctor . ,ly:simple-music-iterator::constructor) - (types . (general-music event skip-event)) - )) + (length-callback . ,ly:music-duration-length) + (iterator-ctor . ,ly:simple-music-iterator::constructor) + (types . (general-music event skip-event)) + )) (SlurEvent . ((description . "Start or end slur. Syntax: @var{note}@code{(} and @var{note}@code{)}") (spanner-id . "") - (types . (general-music post-event span-event event slur-event)) - )) + (types . (general-music post-event span-event event slur-event)) + )) (SoloOneEvent . ((description . "Print @q{Solo@tie{}1}.") - (part-combine-status . solo1) - (types . (general-music event part-combine-event solo-one-event)) - )) + (part-combine-status . solo1) + (types . (general-music event part-combine-event solo-one-event)) + )) (SoloTwoEvent . ((description . "Print @q{Solo@tie{}2}.") - (part-combine-status . solo2) - (types . (general-music event part-combine-event solo-two-event)) - )) + (part-combine-status . solo2) + (types . (general-music event part-combine-event solo-two-event)) + )) (SostenutoEvent . ((description . "Depress or release sostenuto pedal.") - (types . (general-music post-event event pedal-event sostenuto-event)) - )) + (types . (general-music post-event event pedal-event sostenuto-event)) + )) (SpacingSectionEvent . ((description . "Start a new spacing section.") - (types . (general-music event spacing-section-event)))) + (types . (general-music event spacing-section-event)))) (SpanEvent . ((description . "Event for anything that is started at a different time than stopped.") - (types . (general-music event)) - )) + (types . (general-music event)) + )) (StaffSpanEvent . ((description . "Start or stop a staff symbol.") - (types . (general-music event span-event staff-span-event)) - )) + (types . (general-music event span-event staff-span-event)) + )) (StringNumberEvent . ((description . "Specify on which string to play this note. Syntax: @code{\\@var{number}}") - (types . (general-music post-event string-number-event event)) - )) + (types . (general-music post-event string-number-event event)) + )) (StrokeFingerEvent . ((description . "Specify with which finger to pluck a string. Syntax: @code{\\rightHandFinger @var{text}}") - (types . (general-music post-event stroke-finger-event event)) - )) + (types . (general-music post-event stroke-finger-event event)) + )) (SustainEvent . ((description . "Depress or release sustain pedal.") - (types . (general-music post-event event pedal-event sustain-event)) - )) + (types . (general-music post-event event pedal-event sustain-event)) + )) (TempoChangeEvent . ((description . "A metronome mark or tempo indication.") - (types . (general-music event tempo-change-event)) - )) + (types . (general-music event tempo-change-event)) + )) (TextScriptEvent . ((description . "Print text.") - (types . (general-music post-event script-event text-script-event event)) - )) + (types . (general-music post-event script-event text-script-event event)) + )) (TextSpanEvent . ((description . "Start a text spanner, for example, an octavation.") - (types . (general-music post-event span-event event text-span-event)) - )) + (types . (general-music post-event span-event event text-span-event)) + )) (TieEvent . ((description . "A tie. Syntax: @w{@var{note}@code{-~}}") - (types . (general-music post-event tie-event event)) - )) + (types . (general-music post-event tie-event event)) + )) (TimeScaledMusic . ((description . "Multiply durations, as in tuplets. Syntax: @code{\\times @var{fraction} @var{music}}, e.g., @code{\\times 2/3 @{ @dots{} @}} for triplets.") - (length-callback . ,ly:music-wrapper::length-callback) - (start-callback . ,ly:music-wrapper::start-callback) - (iterator-ctor . ,ly:tuplet-iterator::constructor) - (types . (time-scaled-music music-wrapper-music general-music)) - )) + (length-callback . ,ly:music-wrapper::length-callback) + (start-callback . ,ly:music-wrapper::start-callback) + (iterator-ctor . ,ly:tuplet-iterator::constructor) + (types . (time-scaled-music music-wrapper-music general-music)) + )) (TimeSignatureMusic . ((description . "Set a new time signature") @@ -663,87 +663,87 @@ Syntax: @code{\\times @var{fraction} @var{music}}, e.g., (TransposedMusic . ((description . "Music that has been transposed.") - (iterator-ctor . ,ly:music-wrapper-iterator::constructor) - (start-callback . ,ly:music-wrapper::start-callback) - (length-callback . ,ly:music-wrapper::length-callback) - (to-relative-callback . - ,ly:relative-octave-music::no-relative-callback) - (types . (music-wrapper-music general-music transposed-music)) - )) + (iterator-ctor . ,ly:music-wrapper-iterator::constructor) + (start-callback . ,ly:music-wrapper::start-callback) + (length-callback . ,ly:music-wrapper::length-callback) + (to-relative-callback . + ,ly:relative-octave-music::no-relative-callback) + (types . (music-wrapper-music general-music transposed-music)) + )) (TremoloEvent . ((description . "Unmeasured tremolo.") - (types . (general-music post-event event tremolo-event)) - )) + (types . (general-music post-event event tremolo-event)) + )) (TremoloRepeatedMusic . ((description . "Repeated notes denoted by tremolo beams.") - (iterator-ctor . ,ly:chord-tremolo-iterator::constructor) - (start-callback . ,ly:repeated-music::first-start) - ;; the length of the repeat is handled by shifting the note logs - (length-callback . ,ly:repeated-music::folded-music-length) - (types . (general-music repeated-music tremolo-repeated-music)) - )) + (iterator-ctor . ,ly:chord-tremolo-iterator::constructor) + (start-callback . ,ly:repeated-music::first-start) + ;; the length of the repeat is handled by shifting the note logs + (length-callback . ,ly:repeated-music::folded-music-length) + (types . (general-music repeated-music tremolo-repeated-music)) + )) (TremoloSpanEvent . ((description . "Tremolo over two stems.") - (types . (general-music event span-event tremolo-span-event)) - )) + (types . (general-music event span-event tremolo-span-event)) + )) (TrillSpanEvent . ((description . "Start a trill spanner.") - (types . (general-music post-event span-event event trill-span-event)) - )) + (types . (general-music post-event span-event event trill-span-event)) + )) (TupletSpanEvent . ((description . "Used internally to signal where tuplet brackets start and stop.") - (types . (tuplet-span-event span-event event general-music post-event)) - )) + (types . (tuplet-span-event span-event event general-music post-event)) + )) (UnaCordaEvent . ((description . "Depress or release una-corda pedal.") - (types . (general-music post-event event pedal-event una-corda-event)) - )) + (types . (general-music post-event event pedal-event una-corda-event)) + )) (UnfoldedRepeatedMusic . ((description . "Repeated music which is fully written (and played) out.") - (iterator-ctor . ,ly:unfolded-repeat-iterator::constructor) - (start-callback . ,ly:repeated-music::first-start) - (types . (general-music repeated-music unfolded-repeated-music)) - (length-callback . ,ly:repeated-music::unfolded-music-length) - )) + (iterator-ctor . ,ly:unfolded-repeat-iterator::constructor) + (start-callback . ,ly:repeated-music::first-start) + (types . (general-music repeated-music unfolded-repeated-music)) + (length-callback . ,ly:repeated-music::unfolded-music-length) + )) (UnisonoEvent . ((description . "Print @q{a@tie{}2}.") - (part-combine-status . unisono) - (types . (general-music event part-combine-event unisono-event)))) + (part-combine-status . unisono) + (types . (general-music event part-combine-event unisono-event)))) (UnrelativableMusic . ((description . "Music that cannot be converted from relative to absolute notation. For example, transposed music.") - (to-relative-callback . ,ly:relative-octave-music::no-relative-callback) - (iterator-ctor . ,ly:music-wrapper-iterator::constructor) - (length-callback . ,ly:music-wrapper::length-callback) - (types . (music-wrapper-music general-music unrelativable-music)) - )) + (to-relative-callback . ,ly:relative-octave-music::no-relative-callback) + (iterator-ctor . ,ly:music-wrapper-iterator::constructor) + (length-callback . ,ly:music-wrapper::length-callback) + (types . (music-wrapper-music general-music unrelativable-music)) + )) (VoiceSeparator . ((description . "Separate polyphonic voices in simultaneous music. Syntax: @code{\\\\}") - (types . (separator general-music)) - )) + (types . (separator general-music)) + )) (VoltaRepeatedMusic . ((description . "Repeats with alternatives placed sequentially.") - (iterator-ctor . ,ly:volta-repeat-iterator::constructor) - (elements-callback . ,make-volta-set) - (start-callback . ,ly:repeated-music::first-start) - (length-callback . ,ly:repeated-music::volta-music-length) - (types . (general-music repeated-music volta-repeated-music)) - )) + (iterator-ctor . ,ly:volta-repeat-iterator::constructor) + (elements-callback . ,make-volta-set) + (start-callback . ,ly:repeated-music::first-start) + (length-callback . ,ly:repeated-music::volta-music-length) + (types . (general-music repeated-music volta-repeated-music)) + )) )) (set! music-descriptions @@ -756,14 +756,14 @@ Syntax: @code{\\\\}") (set! music-descriptions (map (lambda (x) - (set-object-property! (car x) - 'music-description - (cdr (assq 'description (cdr x)))) - (let ((lst (cdr x))) - (set! lst (assoc-set! lst 'name (car x))) - (set! lst (assq-remove! lst 'description)) - (hashq-set! music-name-to-property-table (car x) lst) - (cons (car x) lst))) + (set-object-property! (car x) + 'music-description + (cdr (assq 'description (cdr x)))) + (let ((lst (cdr x))) + (set! lst (assoc-set! lst 'name (car x))) + (set! lst (assq-remove! lst 'description)) + (hashq-set! music-name-to-property-table (car x) lst) + (cons (car x) lst))) music-descriptions)) (define-safe-public (make-music name . music-properties) @@ -771,33 +771,33 @@ Syntax: @code{\\\\}") according to @code{music-properties}, a list of alternating property symbols and values. E.g: (make-music 'OverrideProperty - 'symbol 'Stem - 'grob-property 'thickness - 'grob-value (* 2 1.5))" + 'symbol 'Stem + 'grob-property 'thickness + 'grob-value (* 2 1.5))" (if (not (symbol? name)) (ly:error (_ "symbol expected: ~S") name)) (let ((props (hashq-ref music-name-to-property-table name '()))) (if (not (pair? props)) - (ly:error (_ "cannot find music object: ~S") name)) + (ly:error (_ "cannot find music object: ~S") name)) (let ((m (ly:make-music props))) (define (set-props mus-props) - (if (and (not (null? mus-props)) - (not (null? (cdr mus-props)))) - (begin - (set! (ly:music-property m (car mus-props)) (cadr mus-props)) - (set-props (cddr mus-props))))) + (if (and (not (null? mus-props)) + (not (null? (cdr mus-props)))) + (begin + (set! (ly:music-property m (car mus-props)) (cadr mus-props)) + (set-props (cddr mus-props))))) (set-props music-properties) m))) (define-public (make-repeated-music name) (let* ((repeated-music (assoc-get name '(("volta" . VoltaRepeatedMusic) - ("unfold" . UnfoldedRepeatedMusic) - ("percent" . PercentRepeatedMusic) - ("tremolo" . TremoloRepeatedMusic)))) - (repeated-music-name (if repeated-music - repeated-music - (begin - (ly:warning (_ "unknown repeat type `~S'") name) - (ly:warning (_ "See define-music-types.scm for supported repeats")) - 'VoltaRepeatedMusic)))) + ("unfold" . UnfoldedRepeatedMusic) + ("percent" . PercentRepeatedMusic) + ("tremolo" . TremoloRepeatedMusic)))) + (repeated-music-name (if repeated-music + repeated-music + (begin + (ly:warning (_ "unknown repeat type `~S'") name) + (ly:warning (_ "See define-music-types.scm for supported repeats")) + 'VoltaRepeatedMusic)))) (make-music repeated-music-name))) diff --git a/scm/define-note-names.scm b/scm/define-note-names.scm index f8b6dad6a4..6136af0c51 100644 --- a/scm/define-note-names.scm +++ b/scm/define-note-names.scm @@ -57,80 +57,80 @@ ;; Dutch: c d e f g a b h (nederlands . ( - (ceses . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) - (ceh . ,(ly:make-pitch -1 0 SEMI-FLAT)) - (ces . ,(ly:make-pitch -1 0 FLAT)) - (ceseh . ,(ly:make-pitch -1 0 THREE-Q-FLAT)) - (c . ,(ly:make-pitch -1 0 NATURAL)) - (cis . ,(ly:make-pitch -1 0 SHARP)) - (cih . ,(ly:make-pitch -1 0 SEMI-SHARP)) - (cisih . ,(ly:make-pitch -1 0 THREE-Q-SHARP)) - (cisis . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) - (deses . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) - - (deh . ,(ly:make-pitch -1 1 SEMI-FLAT)) - (des . ,(ly:make-pitch -1 1 FLAT)) - (deseh . ,(ly:make-pitch -1 1 THREE-Q-FLAT)) - (d . ,(ly:make-pitch -1 1 NATURAL)) - (dis . ,(ly:make-pitch -1 1 SHARP)) - (dih . ,(ly:make-pitch -1 1 SEMI-SHARP)) - (disih . ,(ly:make-pitch -1 1 THREE-Q-SHARP)) - (disis . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) - (eeses . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) - (eses . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) - - (eeh . ,(ly:make-pitch -1 2 SEMI-FLAT)) - (ees . ,(ly:make-pitch -1 2 FLAT)) - (eeseh . ,(ly:make-pitch -1 2 THREE-Q-FLAT)) - (es . ,(ly:make-pitch -1 2 FLAT)) - (e . ,(ly:make-pitch -1 2 NATURAL)) - (eis . ,(ly:make-pitch -1 2 SHARP)) - (eih . ,(ly:make-pitch -1 2 SEMI-SHARP)) - (eisih . ,(ly:make-pitch -1 2 THREE-Q-SHARP)) - (eisis . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) - (feses . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) - - (feh . ,(ly:make-pitch -1 3 SEMI-FLAT)) - (fes . ,(ly:make-pitch -1 3 FLAT)) - (feseh . ,(ly:make-pitch -1 3 THREE-Q-FLAT)) - (f . ,(ly:make-pitch -1 3 NATURAL)) - (fis . ,(ly:make-pitch -1 3 SHARP)) - (fih . ,(ly:make-pitch -1 3 SEMI-SHARP)) - (fisih . ,(ly:make-pitch -1 3 THREE-Q-SHARP)) - (fisis . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) - (geses . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) - - (geh . ,(ly:make-pitch -1 4 SEMI-FLAT)) - (ges . ,(ly:make-pitch -1 4 FLAT)) - (geseh . ,(ly:make-pitch -1 4 THREE-Q-FLAT)) - (g . ,(ly:make-pitch -1 4 NATURAL)) - (gis . ,(ly:make-pitch -1 4 SHARP)) - (gih . ,(ly:make-pitch -1 4 SEMI-SHARP)) - (gisih . ,(ly:make-pitch -1 4 THREE-Q-SHARP)) - (gisis . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) - (aeses . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) - (ases . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) - - (aeh . ,(ly:make-pitch -1 5 SEMI-FLAT)) - (aes . ,(ly:make-pitch -1 5 FLAT)) - (aeseh . ,(ly:make-pitch -1 5 THREE-Q-FLAT)) - (as . ,(ly:make-pitch -1 5 FLAT)) - (a . ,(ly:make-pitch -1 5 NATURAL)) - (ais . ,(ly:make-pitch -1 5 SHARP)) - (aih . ,(ly:make-pitch -1 5 SEMI-SHARP)) - (aisih . ,(ly:make-pitch -1 5 THREE-Q-SHARP)) - (aisis . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) - (beses . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) - - (beh . ,(ly:make-pitch -1 6 SEMI-FLAT)) - (bes . ,(ly:make-pitch -1 6 FLAT)) - (beseh . ,(ly:make-pitch -1 6 THREE-Q-FLAT)) - (b . ,(ly:make-pitch -1 6 NATURAL)) - (bis . ,(ly:make-pitch -1 6 SHARP)) - (bih . ,(ly:make-pitch -1 6 SEMI-SHARP)) - (bisih . ,(ly:make-pitch -1 6 THREE-Q-SHARP)) - (bisis . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) - )) + (ceses . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) + (ceh . ,(ly:make-pitch -1 0 SEMI-FLAT)) + (ces . ,(ly:make-pitch -1 0 FLAT)) + (ceseh . ,(ly:make-pitch -1 0 THREE-Q-FLAT)) + (c . ,(ly:make-pitch -1 0 NATURAL)) + (cis . ,(ly:make-pitch -1 0 SHARP)) + (cih . ,(ly:make-pitch -1 0 SEMI-SHARP)) + (cisih . ,(ly:make-pitch -1 0 THREE-Q-SHARP)) + (cisis . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) + (deses . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) + + (deh . ,(ly:make-pitch -1 1 SEMI-FLAT)) + (des . ,(ly:make-pitch -1 1 FLAT)) + (deseh . ,(ly:make-pitch -1 1 THREE-Q-FLAT)) + (d . ,(ly:make-pitch -1 1 NATURAL)) + (dis . ,(ly:make-pitch -1 1 SHARP)) + (dih . ,(ly:make-pitch -1 1 SEMI-SHARP)) + (disih . ,(ly:make-pitch -1 1 THREE-Q-SHARP)) + (disis . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) + (eeses . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) + (eses . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) + + (eeh . ,(ly:make-pitch -1 2 SEMI-FLAT)) + (ees . ,(ly:make-pitch -1 2 FLAT)) + (eeseh . ,(ly:make-pitch -1 2 THREE-Q-FLAT)) + (es . ,(ly:make-pitch -1 2 FLAT)) + (e . ,(ly:make-pitch -1 2 NATURAL)) + (eis . ,(ly:make-pitch -1 2 SHARP)) + (eih . ,(ly:make-pitch -1 2 SEMI-SHARP)) + (eisih . ,(ly:make-pitch -1 2 THREE-Q-SHARP)) + (eisis . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) + (feses . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) + + (feh . ,(ly:make-pitch -1 3 SEMI-FLAT)) + (fes . ,(ly:make-pitch -1 3 FLAT)) + (feseh . ,(ly:make-pitch -1 3 THREE-Q-FLAT)) + (f . ,(ly:make-pitch -1 3 NATURAL)) + (fis . ,(ly:make-pitch -1 3 SHARP)) + (fih . ,(ly:make-pitch -1 3 SEMI-SHARP)) + (fisih . ,(ly:make-pitch -1 3 THREE-Q-SHARP)) + (fisis . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) + (geses . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) + + (geh . ,(ly:make-pitch -1 4 SEMI-FLAT)) + (ges . ,(ly:make-pitch -1 4 FLAT)) + (geseh . ,(ly:make-pitch -1 4 THREE-Q-FLAT)) + (g . ,(ly:make-pitch -1 4 NATURAL)) + (gis . ,(ly:make-pitch -1 4 SHARP)) + (gih . ,(ly:make-pitch -1 4 SEMI-SHARP)) + (gisih . ,(ly:make-pitch -1 4 THREE-Q-SHARP)) + (gisis . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) + (aeses . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) + (ases . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) + + (aeh . ,(ly:make-pitch -1 5 SEMI-FLAT)) + (aes . ,(ly:make-pitch -1 5 FLAT)) + (aeseh . ,(ly:make-pitch -1 5 THREE-Q-FLAT)) + (as . ,(ly:make-pitch -1 5 FLAT)) + (a . ,(ly:make-pitch -1 5 NATURAL)) + (ais . ,(ly:make-pitch -1 5 SHARP)) + (aih . ,(ly:make-pitch -1 5 SEMI-SHARP)) + (aisih . ,(ly:make-pitch -1 5 THREE-Q-SHARP)) + (aisis . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) + (beses . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) + + (beh . ,(ly:make-pitch -1 6 SEMI-FLAT)) + (bes . ,(ly:make-pitch -1 6 FLAT)) + (beseh . ,(ly:make-pitch -1 6 THREE-Q-FLAT)) + (b . ,(ly:make-pitch -1 6 NATURAL)) + (bis . ,(ly:make-pitch -1 6 SHARP)) + (bih . ,(ly:make-pitch -1 6 SEMI-SHARP)) + (bisih . ,(ly:make-pitch -1 6 THREE-Q-SHARP)) + (bisis . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) + )) ;; Language: Catalan -----------------------------------------------; @@ -149,58 +149,58 @@ ;; Catalan: do re mi fa sol la si (catalan . ( - (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) - (dob . ,(ly:make-pitch -1 0 FLAT)) - (do . ,(ly:make-pitch -1 0 NATURAL)) - (dod . ,(ly:make-pitch -1 0 SHARP)) - (dodd . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) - (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) - (reb . ,(ly:make-pitch -1 1 FLAT)) - (re . ,(ly:make-pitch -1 1 NATURAL)) - (red . ,(ly:make-pitch -1 1 SHARP)) - (redd . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) - (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) - (mib . ,(ly:make-pitch -1 2 FLAT)) - (mi . ,(ly:make-pitch -1 2 NATURAL)) - (mid . ,(ly:make-pitch -1 2 SHARP)) - (midd . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) - (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) - (fab . ,(ly:make-pitch -1 3 FLAT)) - (fa . ,(ly:make-pitch -1 3 NATURAL)) - (fad . ,(ly:make-pitch -1 3 SHARP)) - (fadd . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) - (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) - (solb . ,(ly:make-pitch -1 4 FLAT)) - (sol . ,(ly:make-pitch -1 4 NATURAL)) - (sold . ,(ly:make-pitch -1 4 SHARP)) - (soldd . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) - (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) - (lab . ,(ly:make-pitch -1 5 FLAT)) - (la . ,(ly:make-pitch -1 5 NATURAL)) - (lad . ,(ly:make-pitch -1 5 SHARP)) - (ladd . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) - (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) - (sib . ,(ly:make-pitch -1 6 FLAT)) - (si . ,(ly:make-pitch -1 6 NATURAL)) - (sid . ,(ly:make-pitch -1 6 SHARP)) - (sidd . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) - - ;; Now that we have espanol.ly, should these be junked? --jcn - (dos . ,(ly:make-pitch -1 0 SHARP)) - (doss . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) - (res . ,(ly:make-pitch -1 1 SHARP)) - (ress . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) - (mis . ,(ly:make-pitch -1 2 SHARP)) - (miss . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) - (fas . ,(ly:make-pitch -1 3 SHARP)) - (fass . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) - (sols . ,(ly:make-pitch -1 4 SHARP)) - (solss . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) - (las . ,(ly:make-pitch -1 5 SHARP)) - (lass . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) - (sis . ,(ly:make-pitch -1 6 SHARP)) - (siss . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) - )) + (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) + (dob . ,(ly:make-pitch -1 0 FLAT)) + (do . ,(ly:make-pitch -1 0 NATURAL)) + (dod . ,(ly:make-pitch -1 0 SHARP)) + (dodd . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) + (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) + (reb . ,(ly:make-pitch -1 1 FLAT)) + (re . ,(ly:make-pitch -1 1 NATURAL)) + (red . ,(ly:make-pitch -1 1 SHARP)) + (redd . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) + (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) + (mib . ,(ly:make-pitch -1 2 FLAT)) + (mi . ,(ly:make-pitch -1 2 NATURAL)) + (mid . ,(ly:make-pitch -1 2 SHARP)) + (midd . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) + (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) + (fab . ,(ly:make-pitch -1 3 FLAT)) + (fa . ,(ly:make-pitch -1 3 NATURAL)) + (fad . ,(ly:make-pitch -1 3 SHARP)) + (fadd . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) + (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) + (solb . ,(ly:make-pitch -1 4 FLAT)) + (sol . ,(ly:make-pitch -1 4 NATURAL)) + (sold . ,(ly:make-pitch -1 4 SHARP)) + (soldd . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) + (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) + (lab . ,(ly:make-pitch -1 5 FLAT)) + (la . ,(ly:make-pitch -1 5 NATURAL)) + (lad . ,(ly:make-pitch -1 5 SHARP)) + (ladd . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) + (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) + (sib . ,(ly:make-pitch -1 6 FLAT)) + (si . ,(ly:make-pitch -1 6 NATURAL)) + (sid . ,(ly:make-pitch -1 6 SHARP)) + (sidd . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) + + ;; Now that we have espanol.ly, should these be junked? --jcn + (dos . ,(ly:make-pitch -1 0 SHARP)) + (doss . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) + (res . ,(ly:make-pitch -1 1 SHARP)) + (ress . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) + (mis . ,(ly:make-pitch -1 2 SHARP)) + (miss . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) + (fas . ,(ly:make-pitch -1 3 SHARP)) + (fass . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) + (sols . ,(ly:make-pitch -1 4 SHARP)) + (solss . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) + (las . ,(ly:make-pitch -1 5 SHARP)) + (lass . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) + (sis . ,(ly:make-pitch -1 6 SHARP)) + (siss . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) + )) ;; Language: Deutsch -----------------------------------------------; @@ -221,78 +221,78 @@ ;; German: c d e f g a b h (deutsch . ( - (ceses . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) - (ceseh . ,(ly:make-pitch -1 0 THREE-Q-FLAT)) - (ces . ,(ly:make-pitch -1 0 FLAT)) - (ceh . ,(ly:make-pitch -1 0 SEMI-FLAT)) - (c . ,(ly:make-pitch -1 0 NATURAL)) - (cih . ,(ly:make-pitch -1 0 SEMI-SHARP)) - (cis . ,(ly:make-pitch -1 0 SHARP)) - (cisih . ,(ly:make-pitch -1 0 THREE-Q-SHARP)) - (cisis . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) - - (deses . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) - (deseh . ,(ly:make-pitch -1 1 THREE-Q-FLAT)) - (des . ,(ly:make-pitch -1 1 FLAT)) - (deh . ,(ly:make-pitch -1 1 SEMI-FLAT)) - (d . ,(ly:make-pitch -1 1 NATURAL)) - (dih . ,(ly:make-pitch -1 1 SEMI-SHARP)) - (dis . ,(ly:make-pitch -1 1 SHARP)) - (disih . ,(ly:make-pitch -1 1 THREE-Q-SHARP)) - (disis . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) - - (eses . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) - (eseh . ,(ly:make-pitch -1 2 THREE-Q-FLAT)) - (es . ,(ly:make-pitch -1 2 FLAT)) - (eeh . ,(ly:make-pitch -1 2 SEMI-FLAT)) - (e . ,(ly:make-pitch -1 2 NATURAL)) - (eih . ,(ly:make-pitch -1 2 SEMI-SHARP)) - (eis . ,(ly:make-pitch -1 2 SHARP)) - (eisih . ,(ly:make-pitch -1 2 THREE-Q-SHARP)) - (eisis . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) - - (feses . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) - (feseh . ,(ly:make-pitch -1 3 THREE-Q-FLAT)) - (fes . ,(ly:make-pitch -1 3 FLAT)) - (feh . ,(ly:make-pitch -1 3 SEMI-FLAT)) - (f . ,(ly:make-pitch -1 3 NATURAL)) - (fih . ,(ly:make-pitch -1 3 SEMI-SHARP)) - (fis . ,(ly:make-pitch -1 3 SHARP)) - (fisih . ,(ly:make-pitch -1 3 THREE-Q-SHARP)) - (fisis . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) - - (geses . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) - (geseh . ,(ly:make-pitch -1 4 THREE-Q-FLAT)) - (ges . ,(ly:make-pitch -1 4 FLAT)) - (geh . ,(ly:make-pitch -1 4 SEMI-FLAT)) - (g . ,(ly:make-pitch -1 4 NATURAL)) - (gih . ,(ly:make-pitch -1 4 SEMI-SHARP)) - (gis . ,(ly:make-pitch -1 4 SHARP)) - (gisih . ,(ly:make-pitch -1 4 THREE-Q-SHARP)) - (gisis . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) - - (asas . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) - (asah . ,(ly:make-pitch -1 5 THREE-Q-FLAT)) - (ases . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) ;;non-standard name for asas - (aseh . ,(ly:make-pitch -1 5 THREE-Q-FLAT)) - (as . ,(ly:make-pitch -1 5 FLAT)) - (aeh . ,(ly:make-pitch -1 5 SEMI-FLAT)) - (a . ,(ly:make-pitch -1 5 NATURAL)) - (aih . ,(ly:make-pitch -1 5 SEMI-SHARP)) - (ais . ,(ly:make-pitch -1 5 SHARP)) - (aisih . ,(ly:make-pitch -1 5 THREE-Q-SHARP)) - (aisis . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) - - (heses . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) - (heseh . ,(ly:make-pitch -1 6 THREE-Q-FLAT)) - (b . ,(ly:make-pitch -1 6 FLAT)) - (beh . ,(ly:make-pitch -1 6 SEMI-FLAT)) - (h . ,(ly:make-pitch -1 6 NATURAL)) - (hih . ,(ly:make-pitch -1 6 SEMI-SHARP)) - (his . ,(ly:make-pitch -1 6 SHARP)) - (hisih . ,(ly:make-pitch -1 6 THREE-Q-SHARP)) - (hisis . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) - )) + (ceses . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) + (ceseh . ,(ly:make-pitch -1 0 THREE-Q-FLAT)) + (ces . ,(ly:make-pitch -1 0 FLAT)) + (ceh . ,(ly:make-pitch -1 0 SEMI-FLAT)) + (c . ,(ly:make-pitch -1 0 NATURAL)) + (cih . ,(ly:make-pitch -1 0 SEMI-SHARP)) + (cis . ,(ly:make-pitch -1 0 SHARP)) + (cisih . ,(ly:make-pitch -1 0 THREE-Q-SHARP)) + (cisis . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) + + (deses . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) + (deseh . ,(ly:make-pitch -1 1 THREE-Q-FLAT)) + (des . ,(ly:make-pitch -1 1 FLAT)) + (deh . ,(ly:make-pitch -1 1 SEMI-FLAT)) + (d . ,(ly:make-pitch -1 1 NATURAL)) + (dih . ,(ly:make-pitch -1 1 SEMI-SHARP)) + (dis . ,(ly:make-pitch -1 1 SHARP)) + (disih . ,(ly:make-pitch -1 1 THREE-Q-SHARP)) + (disis . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) + + (eses . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) + (eseh . ,(ly:make-pitch -1 2 THREE-Q-FLAT)) + (es . ,(ly:make-pitch -1 2 FLAT)) + (eeh . ,(ly:make-pitch -1 2 SEMI-FLAT)) + (e . ,(ly:make-pitch -1 2 NATURAL)) + (eih . ,(ly:make-pitch -1 2 SEMI-SHARP)) + (eis . ,(ly:make-pitch -1 2 SHARP)) + (eisih . ,(ly:make-pitch -1 2 THREE-Q-SHARP)) + (eisis . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) + + (feses . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) + (feseh . ,(ly:make-pitch -1 3 THREE-Q-FLAT)) + (fes . ,(ly:make-pitch -1 3 FLAT)) + (feh . ,(ly:make-pitch -1 3 SEMI-FLAT)) + (f . ,(ly:make-pitch -1 3 NATURAL)) + (fih . ,(ly:make-pitch -1 3 SEMI-SHARP)) + (fis . ,(ly:make-pitch -1 3 SHARP)) + (fisih . ,(ly:make-pitch -1 3 THREE-Q-SHARP)) + (fisis . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) + + (geses . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) + (geseh . ,(ly:make-pitch -1 4 THREE-Q-FLAT)) + (ges . ,(ly:make-pitch -1 4 FLAT)) + (geh . ,(ly:make-pitch -1 4 SEMI-FLAT)) + (g . ,(ly:make-pitch -1 4 NATURAL)) + (gih . ,(ly:make-pitch -1 4 SEMI-SHARP)) + (gis . ,(ly:make-pitch -1 4 SHARP)) + (gisih . ,(ly:make-pitch -1 4 THREE-Q-SHARP)) + (gisis . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) + + (asas . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) + (asah . ,(ly:make-pitch -1 5 THREE-Q-FLAT)) + (ases . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) ;;non-standard name for asas + (aseh . ,(ly:make-pitch -1 5 THREE-Q-FLAT)) + (as . ,(ly:make-pitch -1 5 FLAT)) + (aeh . ,(ly:make-pitch -1 5 SEMI-FLAT)) + (a . ,(ly:make-pitch -1 5 NATURAL)) + (aih . ,(ly:make-pitch -1 5 SEMI-SHARP)) + (ais . ,(ly:make-pitch -1 5 SHARP)) + (aisih . ,(ly:make-pitch -1 5 THREE-Q-SHARP)) + (aisis . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) + + (heses . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) + (heseh . ,(ly:make-pitch -1 6 THREE-Q-FLAT)) + (b . ,(ly:make-pitch -1 6 FLAT)) + (beh . ,(ly:make-pitch -1 6 SEMI-FLAT)) + (h . ,(ly:make-pitch -1 6 NATURAL)) + (hih . ,(ly:make-pitch -1 6 SEMI-SHARP)) + (his . ,(ly:make-pitch -1 6 SHARP)) + (hisih . ,(ly:make-pitch -1 6 THREE-Q-SHARP)) + (hisis . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) + )) ;; Language: English -----------------------------------------------; @@ -310,119 +310,119 @@ ;; tqs = three-quarter[-tones] sharp (english . ( - (cflatflat . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) - (cflat . ,(ly:make-pitch -1 0 FLAT)) - (c . ,(ly:make-pitch -1 0 NATURAL)) - (csharp . ,(ly:make-pitch -1 0 SHARP)) - (csharpsharp . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) - (dflatflat . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) - (dflat . ,(ly:make-pitch -1 1 FLAT)) - (d . ,(ly:make-pitch -1 1 NATURAL)) - (dsharp . ,(ly:make-pitch -1 1 SHARP)) - (dsharpsharp . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) - (eflatflat . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) - (eflat . ,(ly:make-pitch -1 2 FLAT)) - (e . ,(ly:make-pitch -1 2 NATURAL)) - (esharp . ,(ly:make-pitch -1 2 SHARP)) - (esharpsharp . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) - (fflatflat . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) - (fflat . ,(ly:make-pitch -1 3 FLAT)) - (f . ,(ly:make-pitch -1 3 NATURAL)) - (fsharp . ,(ly:make-pitch -1 3 SHARP)) - (fsharpsharp . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) - (gflatflat . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) - (gflat . ,(ly:make-pitch -1 4 FLAT)) - (g . ,(ly:make-pitch -1 4 NATURAL)) - (gsharp . ,(ly:make-pitch -1 4 SHARP)) - (gsharpsharp . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) - (aflatflat . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) - (aflat . ,(ly:make-pitch -1 5 FLAT)) - (a . ,(ly:make-pitch -1 5 NATURAL)) - (asharp . ,(ly:make-pitch -1 5 SHARP)) - (asharpsharp . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) - (bflatflat . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) - (bflat . ,(ly:make-pitch -1 6 FLAT)) - (b . ,(ly:make-pitch -1 6 NATURAL)) - (bsharp . ,(ly:make-pitch -1 6 SHARP)) - (bsharpsharp . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) - - (cff . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) - (ctqf . ,(ly:make-pitch -1 0 THREE-Q-FLAT)) - (cf . ,(ly:make-pitch -1 0 FLAT)) - (cqf . ,(ly:make-pitch -1 0 SEMI-FLAT)) - (c . ,(ly:make-pitch -1 0 NATURAL)) - (cqs . ,(ly:make-pitch -1 0 SEMI-SHARP)) - (cs . ,(ly:make-pitch -1 0 SHARP)) - (ctqs . ,(ly:make-pitch -1 0 THREE-Q-SHARP)) - (css . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) - (cx . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) - - (dff . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) - (dtqf . ,(ly:make-pitch -1 1 THREE-Q-FLAT)) - (df . ,(ly:make-pitch -1 1 FLAT)) - (dqf . ,(ly:make-pitch -1 1 SEMI-FLAT)) - (d . ,(ly:make-pitch -1 1 NATURAL)) - (dqs . ,(ly:make-pitch -1 1 SEMI-SHARP)) - (ds . ,(ly:make-pitch -1 1 SHARP)) - (dtqs . ,(ly:make-pitch -1 1 THREE-Q-SHARP)) - (dss . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) - (dx . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) - - (eff . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) - (etqf . ,(ly:make-pitch -1 2 THREE-Q-FLAT)) - (ef . ,(ly:make-pitch -1 2 FLAT)) - (eqf . ,(ly:make-pitch -1 2 SEMI-FLAT)) - (e . ,(ly:make-pitch -1 2 NATURAL)) - (eqs . ,(ly:make-pitch -1 2 SEMI-SHARP)) - (es . ,(ly:make-pitch -1 2 SHARP)) - (etqs . ,(ly:make-pitch -1 2 THREE-Q-SHARP)) - (ess . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) - (ex . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) - - (fff . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) - (ftqf . ,(ly:make-pitch -1 3 THREE-Q-FLAT)) - (ff . ,(ly:make-pitch -1 3 FLAT)) - (fqf . ,(ly:make-pitch -1 3 SEMI-FLAT)) - (f . ,(ly:make-pitch -1 3 NATURAL)) - (fqs . ,(ly:make-pitch -1 3 SEMI-SHARP)) - (fs . ,(ly:make-pitch -1 3 SHARP)) - (ftqs . ,(ly:make-pitch -1 3 THREE-Q-SHARP)) - (fss . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) - (fx . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) - - (gff . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) - (gtqf . ,(ly:make-pitch -1 4 THREE-Q-FLAT)) - (gf . ,(ly:make-pitch -1 4 FLAT)) - (gqf . ,(ly:make-pitch -1 4 SEMI-FLAT)) - (g . ,(ly:make-pitch -1 4 NATURAL)) - (gqs . ,(ly:make-pitch -1 4 SEMI-SHARP)) - (gs . ,(ly:make-pitch -1 4 SHARP)) - (gtqs . ,(ly:make-pitch -1 4 THREE-Q-SHARP)) - (gss . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) - (gx . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) - - (aff . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) - (atqf . ,(ly:make-pitch -1 5 THREE-Q-FLAT)) - (af . ,(ly:make-pitch -1 5 FLAT)) - (aqf . ,(ly:make-pitch -1 5 SEMI-FLAT)) - (a . ,(ly:make-pitch -1 5 NATURAL)) - (aqs . ,(ly:make-pitch -1 5 SEMI-SHARP)) - (as . ,(ly:make-pitch -1 5 SHARP)) - (atqs . ,(ly:make-pitch -1 5 THREE-Q-SHARP)) - (ass . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) - (ax . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) - - (bff . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) - (btqf . ,(ly:make-pitch -1 6 THREE-Q-FLAT)) - (bf . ,(ly:make-pitch -1 6 FLAT)) - (bqf . ,(ly:make-pitch -1 6 SEMI-FLAT)) - (b . ,(ly:make-pitch -1 6 NATURAL)) - (bqs . ,(ly:make-pitch -1 6 SEMI-SHARP)) - (bs . ,(ly:make-pitch -1 6 SHARP)) - (btqs . ,(ly:make-pitch -1 6 THREE-Q-SHARP)) - (bss . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) - (bx . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) - )) + (cflatflat . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) + (cflat . ,(ly:make-pitch -1 0 FLAT)) + (c . ,(ly:make-pitch -1 0 NATURAL)) + (csharp . ,(ly:make-pitch -1 0 SHARP)) + (csharpsharp . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) + (dflatflat . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) + (dflat . ,(ly:make-pitch -1 1 FLAT)) + (d . ,(ly:make-pitch -1 1 NATURAL)) + (dsharp . ,(ly:make-pitch -1 1 SHARP)) + (dsharpsharp . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) + (eflatflat . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) + (eflat . ,(ly:make-pitch -1 2 FLAT)) + (e . ,(ly:make-pitch -1 2 NATURAL)) + (esharp . ,(ly:make-pitch -1 2 SHARP)) + (esharpsharp . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) + (fflatflat . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) + (fflat . ,(ly:make-pitch -1 3 FLAT)) + (f . ,(ly:make-pitch -1 3 NATURAL)) + (fsharp . ,(ly:make-pitch -1 3 SHARP)) + (fsharpsharp . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) + (gflatflat . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) + (gflat . ,(ly:make-pitch -1 4 FLAT)) + (g . ,(ly:make-pitch -1 4 NATURAL)) + (gsharp . ,(ly:make-pitch -1 4 SHARP)) + (gsharpsharp . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) + (aflatflat . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) + (aflat . ,(ly:make-pitch -1 5 FLAT)) + (a . ,(ly:make-pitch -1 5 NATURAL)) + (asharp . ,(ly:make-pitch -1 5 SHARP)) + (asharpsharp . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) + (bflatflat . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) + (bflat . ,(ly:make-pitch -1 6 FLAT)) + (b . ,(ly:make-pitch -1 6 NATURAL)) + (bsharp . ,(ly:make-pitch -1 6 SHARP)) + (bsharpsharp . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) + + (cff . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) + (ctqf . ,(ly:make-pitch -1 0 THREE-Q-FLAT)) + (cf . ,(ly:make-pitch -1 0 FLAT)) + (cqf . ,(ly:make-pitch -1 0 SEMI-FLAT)) + (c . ,(ly:make-pitch -1 0 NATURAL)) + (cqs . ,(ly:make-pitch -1 0 SEMI-SHARP)) + (cs . ,(ly:make-pitch -1 0 SHARP)) + (ctqs . ,(ly:make-pitch -1 0 THREE-Q-SHARP)) + (css . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) + (cx . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) + + (dff . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) + (dtqf . ,(ly:make-pitch -1 1 THREE-Q-FLAT)) + (df . ,(ly:make-pitch -1 1 FLAT)) + (dqf . ,(ly:make-pitch -1 1 SEMI-FLAT)) + (d . ,(ly:make-pitch -1 1 NATURAL)) + (dqs . ,(ly:make-pitch -1 1 SEMI-SHARP)) + (ds . ,(ly:make-pitch -1 1 SHARP)) + (dtqs . ,(ly:make-pitch -1 1 THREE-Q-SHARP)) + (dss . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) + (dx . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) + + (eff . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) + (etqf . ,(ly:make-pitch -1 2 THREE-Q-FLAT)) + (ef . ,(ly:make-pitch -1 2 FLAT)) + (eqf . ,(ly:make-pitch -1 2 SEMI-FLAT)) + (e . ,(ly:make-pitch -1 2 NATURAL)) + (eqs . ,(ly:make-pitch -1 2 SEMI-SHARP)) + (es . ,(ly:make-pitch -1 2 SHARP)) + (etqs . ,(ly:make-pitch -1 2 THREE-Q-SHARP)) + (ess . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) + (ex . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) + + (fff . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) + (ftqf . ,(ly:make-pitch -1 3 THREE-Q-FLAT)) + (ff . ,(ly:make-pitch -1 3 FLAT)) + (fqf . ,(ly:make-pitch -1 3 SEMI-FLAT)) + (f . ,(ly:make-pitch -1 3 NATURAL)) + (fqs . ,(ly:make-pitch -1 3 SEMI-SHARP)) + (fs . ,(ly:make-pitch -1 3 SHARP)) + (ftqs . ,(ly:make-pitch -1 3 THREE-Q-SHARP)) + (fss . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) + (fx . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) + + (gff . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) + (gtqf . ,(ly:make-pitch -1 4 THREE-Q-FLAT)) + (gf . ,(ly:make-pitch -1 4 FLAT)) + (gqf . ,(ly:make-pitch -1 4 SEMI-FLAT)) + (g . ,(ly:make-pitch -1 4 NATURAL)) + (gqs . ,(ly:make-pitch -1 4 SEMI-SHARP)) + (gs . ,(ly:make-pitch -1 4 SHARP)) + (gtqs . ,(ly:make-pitch -1 4 THREE-Q-SHARP)) + (gss . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) + (gx . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) + + (aff . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) + (atqf . ,(ly:make-pitch -1 5 THREE-Q-FLAT)) + (af . ,(ly:make-pitch -1 5 FLAT)) + (aqf . ,(ly:make-pitch -1 5 SEMI-FLAT)) + (a . ,(ly:make-pitch -1 5 NATURAL)) + (aqs . ,(ly:make-pitch -1 5 SEMI-SHARP)) + (as . ,(ly:make-pitch -1 5 SHARP)) + (atqs . ,(ly:make-pitch -1 5 THREE-Q-SHARP)) + (ass . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) + (ax . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) + + (bff . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) + (btqf . ,(ly:make-pitch -1 6 THREE-Q-FLAT)) + (bf . ,(ly:make-pitch -1 6 FLAT)) + (bqf . ,(ly:make-pitch -1 6 SEMI-FLAT)) + (b . ,(ly:make-pitch -1 6 NATURAL)) + (bqs . ,(ly:make-pitch -1 6 SEMI-SHARP)) + (bs . ,(ly:make-pitch -1 6 SHARP)) + (btqs . ,(ly:make-pitch -1 6 THREE-Q-SHARP)) + (bss . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) + (bx . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) + )) ;; Language: Espanol -----------------------------------------------; @@ -444,83 +444,83 @@ ;; Spanish: do re mi fa sol la si (espanol . ( - (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) - (dotcb . ,(ly:make-pitch -1 0 THREE-Q-FLAT)) - (dob . ,(ly:make-pitch -1 0 FLAT)) - (docb . ,(ly:make-pitch -1 0 SEMI-FLAT)) - (do . ,(ly:make-pitch -1 0 NATURAL)) - (docs . ,(ly:make-pitch -1 0 SEMI-SHARP)) - (dos . ,(ly:make-pitch -1 0 SHARP)) - (dotcs . ,(ly:make-pitch -1 0 THREE-Q-SHARP)) - (doss . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) - (dox . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) - - (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) - (retcb . ,(ly:make-pitch -1 1 THREE-Q-FLAT)) - (reb . ,(ly:make-pitch -1 1 FLAT)) - (recb . ,(ly:make-pitch -1 1 SEMI-FLAT)) - (re . ,(ly:make-pitch -1 1 NATURAL)) - (recs . ,(ly:make-pitch -1 1 SEMI-SHARP)) - (res . ,(ly:make-pitch -1 1 SHARP)) - (retcs . ,(ly:make-pitch -1 1 THREE-Q-SHARP)) - (ress . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) - (rex . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) - - (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) - (mitcb . ,(ly:make-pitch -1 2 THREE-Q-FLAT)) - (mib . ,(ly:make-pitch -1 2 FLAT)) - (micb . ,(ly:make-pitch -1 2 SEMI-FLAT)) - (mi . ,(ly:make-pitch -1 2 NATURAL)) - (mics . ,(ly:make-pitch -1 2 SEMI-SHARP)) - (mis . ,(ly:make-pitch -1 2 SHARP)) - (mitcs . ,(ly:make-pitch -1 2 THREE-Q-SHARP)) - (miss . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) - (mix . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) - - (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) - (fatcb . ,(ly:make-pitch -1 3 THREE-Q-FLAT)) - (fab . ,(ly:make-pitch -1 3 FLAT)) - (facb . ,(ly:make-pitch -1 3 SEMI-FLAT)) - (fa . ,(ly:make-pitch -1 3 NATURAL)) - (facs . ,(ly:make-pitch -1 3 SEMI-SHARP)) - (fas . ,(ly:make-pitch -1 3 SHARP)) - (fatcs . ,(ly:make-pitch -1 3 THREE-Q-SHARP)) - (fass . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) - (fax . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) - - (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) - (soltcb . ,(ly:make-pitch -1 4 THREE-Q-FLAT)) - (solb . ,(ly:make-pitch -1 4 FLAT)) - (solcb . ,(ly:make-pitch -1 4 SEMI-FLAT)) - (sol . ,(ly:make-pitch -1 4 NATURAL)) - (solcs . ,(ly:make-pitch -1 4 SEMI-SHARP)) - (sols . ,(ly:make-pitch -1 4 SHARP)) - (soltcs . ,(ly:make-pitch -1 4 THREE-Q-SHARP)) - (solss . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) - (solx . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) - - (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) - (latcb . ,(ly:make-pitch -1 5 THREE-Q-FLAT)) - (lab . ,(ly:make-pitch -1 5 FLAT)) - (lacb . ,(ly:make-pitch -1 5 SEMI-FLAT)) - (la . ,(ly:make-pitch -1 5 NATURAL)) - (lacs . ,(ly:make-pitch -1 5 SEMI-SHARP)) - (las . ,(ly:make-pitch -1 5 SHARP)) - (latcs . ,(ly:make-pitch -1 5 THREE-Q-SHARP)) - (lass . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) - (lax . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) - - (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) - (sitcb . ,(ly:make-pitch -1 6 THREE-Q-FLAT)) - (sib . ,(ly:make-pitch -1 6 FLAT)) - (sicb . ,(ly:make-pitch -1 6 SEMI-FLAT)) - (si . ,(ly:make-pitch -1 6 NATURAL)) - (sics . ,(ly:make-pitch -1 6 SEMI-SHARP)) - (sis . ,(ly:make-pitch -1 6 SHARP)) - (sitcs . ,(ly:make-pitch -1 6 THREE-Q-SHARP)) - (siss . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) - (six . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) - )) + (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) + (dotcb . ,(ly:make-pitch -1 0 THREE-Q-FLAT)) + (dob . ,(ly:make-pitch -1 0 FLAT)) + (docb . ,(ly:make-pitch -1 0 SEMI-FLAT)) + (do . ,(ly:make-pitch -1 0 NATURAL)) + (docs . ,(ly:make-pitch -1 0 SEMI-SHARP)) + (dos . ,(ly:make-pitch -1 0 SHARP)) + (dotcs . ,(ly:make-pitch -1 0 THREE-Q-SHARP)) + (doss . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) + (dox . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) + + (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) + (retcb . ,(ly:make-pitch -1 1 THREE-Q-FLAT)) + (reb . ,(ly:make-pitch -1 1 FLAT)) + (recb . ,(ly:make-pitch -1 1 SEMI-FLAT)) + (re . ,(ly:make-pitch -1 1 NATURAL)) + (recs . ,(ly:make-pitch -1 1 SEMI-SHARP)) + (res . ,(ly:make-pitch -1 1 SHARP)) + (retcs . ,(ly:make-pitch -1 1 THREE-Q-SHARP)) + (ress . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) + (rex . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) + + (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) + (mitcb . ,(ly:make-pitch -1 2 THREE-Q-FLAT)) + (mib . ,(ly:make-pitch -1 2 FLAT)) + (micb . ,(ly:make-pitch -1 2 SEMI-FLAT)) + (mi . ,(ly:make-pitch -1 2 NATURAL)) + (mics . ,(ly:make-pitch -1 2 SEMI-SHARP)) + (mis . ,(ly:make-pitch -1 2 SHARP)) + (mitcs . ,(ly:make-pitch -1 2 THREE-Q-SHARP)) + (miss . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) + (mix . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) + + (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) + (fatcb . ,(ly:make-pitch -1 3 THREE-Q-FLAT)) + (fab . ,(ly:make-pitch -1 3 FLAT)) + (facb . ,(ly:make-pitch -1 3 SEMI-FLAT)) + (fa . ,(ly:make-pitch -1 3 NATURAL)) + (facs . ,(ly:make-pitch -1 3 SEMI-SHARP)) + (fas . ,(ly:make-pitch -1 3 SHARP)) + (fatcs . ,(ly:make-pitch -1 3 THREE-Q-SHARP)) + (fass . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) + (fax . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) + + (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) + (soltcb . ,(ly:make-pitch -1 4 THREE-Q-FLAT)) + (solb . ,(ly:make-pitch -1 4 FLAT)) + (solcb . ,(ly:make-pitch -1 4 SEMI-FLAT)) + (sol . ,(ly:make-pitch -1 4 NATURAL)) + (solcs . ,(ly:make-pitch -1 4 SEMI-SHARP)) + (sols . ,(ly:make-pitch -1 4 SHARP)) + (soltcs . ,(ly:make-pitch -1 4 THREE-Q-SHARP)) + (solss . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) + (solx . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) + + (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) + (latcb . ,(ly:make-pitch -1 5 THREE-Q-FLAT)) + (lab . ,(ly:make-pitch -1 5 FLAT)) + (lacb . ,(ly:make-pitch -1 5 SEMI-FLAT)) + (la . ,(ly:make-pitch -1 5 NATURAL)) + (lacs . ,(ly:make-pitch -1 5 SEMI-SHARP)) + (las . ,(ly:make-pitch -1 5 SHARP)) + (latcs . ,(ly:make-pitch -1 5 THREE-Q-SHARP)) + (lass . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) + (lax . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) + + (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) + (sitcb . ,(ly:make-pitch -1 6 THREE-Q-FLAT)) + (sib . ,(ly:make-pitch -1 6 FLAT)) + (sicb . ,(ly:make-pitch -1 6 SEMI-FLAT)) + (si . ,(ly:make-pitch -1 6 NATURAL)) + (sics . ,(ly:make-pitch -1 6 SEMI-SHARP)) + (sis . ,(ly:make-pitch -1 6 SHARP)) + (sitcs . ,(ly:make-pitch -1 6 THREE-Q-SHARP)) + (siss . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) + (six . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) + )) ;; Language: Italiano ----------------------------------------------; @@ -541,77 +541,77 @@ ;; Italian: do re mi fa sol la si (italiano . ( - (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) - (dobsb . ,(ly:make-pitch -1 0 THREE-Q-FLAT)) - (dob . ,(ly:make-pitch -1 0 FLAT)) - (dosb . ,(ly:make-pitch -1 0 SEMI-FLAT)) - (do . ,(ly:make-pitch -1 0 NATURAL)) - (dosd . ,(ly:make-pitch -1 0 SEMI-SHARP)) - (dod . ,(ly:make-pitch -1 0 SHARP)) - (dodsd . ,(ly:make-pitch -1 0 THREE-Q-SHARP)) - (dodd . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) - - (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) - (rebsb . ,(ly:make-pitch -1 1 THREE-Q-FLAT)) - (reb . ,(ly:make-pitch -1 1 FLAT)) - (resb . ,(ly:make-pitch -1 1 SEMI-FLAT)) - (re . ,(ly:make-pitch -1 1 NATURAL)) - (resd . ,(ly:make-pitch -1 1 SEMI-SHARP)) - (red . ,(ly:make-pitch -1 1 SHARP)) - (redsd . ,(ly:make-pitch -1 1 THREE-Q-SHARP)) - (redd . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) - - (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) - (mibsb . ,(ly:make-pitch -1 2 THREE-Q-FLAT)) - (mib . ,(ly:make-pitch -1 2 FLAT)) - (misb . ,(ly:make-pitch -1 2 SEMI-FLAT)) - (mi . ,(ly:make-pitch -1 2 NATURAL)) - (misd . ,(ly:make-pitch -1 2 SEMI-SHARP)) - (mid . ,(ly:make-pitch -1 2 SHARP)) - (midsd . ,(ly:make-pitch -1 2 THREE-Q-SHARP)) - (midd . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) - - (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) - (fabsb . ,(ly:make-pitch -1 3 THREE-Q-FLAT)) - (fab . ,(ly:make-pitch -1 3 FLAT)) - (fasb . ,(ly:make-pitch -1 3 SEMI-FLAT)) - (fa . ,(ly:make-pitch -1 3 NATURAL)) - (fasd . ,(ly:make-pitch -1 3 SEMI-SHARP)) - (fad . ,(ly:make-pitch -1 3 SHARP)) - (fadsd . ,(ly:make-pitch -1 3 THREE-Q-SHARP)) - (fadd . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) - - (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) - (solbsb . ,(ly:make-pitch -1 4 THREE-Q-FLAT)) - (solb . ,(ly:make-pitch -1 4 FLAT)) - (solsb . ,(ly:make-pitch -1 4 SEMI-FLAT)) - (sol . ,(ly:make-pitch -1 4 NATURAL)) - (solsd . ,(ly:make-pitch -1 4 SEMI-SHARP)) - (sold . ,(ly:make-pitch -1 4 SHARP)) - (soldsd . ,(ly:make-pitch -1 4 THREE-Q-SHARP)) - (soldd . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) - - (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) - (labsb . ,(ly:make-pitch -1 5 THREE-Q-FLAT)) - (lab . ,(ly:make-pitch -1 5 FLAT)) - (lasb . ,(ly:make-pitch -1 5 SEMI-FLAT)) - (la . ,(ly:make-pitch -1 5 NATURAL)) - (lasd . ,(ly:make-pitch -1 5 SEMI-SHARP)) - (lad . ,(ly:make-pitch -1 5 SHARP)) - (ladsd . ,(ly:make-pitch -1 5 THREE-Q-SHARP)) - (ladd . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) - - (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) - (sibsb . ,(ly:make-pitch -1 6 THREE-Q-FLAT)) - (sib . ,(ly:make-pitch -1 6 FLAT)) - (sisb . ,(ly:make-pitch -1 6 SEMI-FLAT)) - (si . ,(ly:make-pitch -1 6 NATURAL)) - (sisd . ,(ly:make-pitch -1 6 SEMI-SHARP)) - (sid . ,(ly:make-pitch -1 6 SHARP)) - (sidsd . ,(ly:make-pitch -1 6 THREE-Q-SHARP)) - (sidd . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) - - )) + (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) + (dobsb . ,(ly:make-pitch -1 0 THREE-Q-FLAT)) + (dob . ,(ly:make-pitch -1 0 FLAT)) + (dosb . ,(ly:make-pitch -1 0 SEMI-FLAT)) + (do . ,(ly:make-pitch -1 0 NATURAL)) + (dosd . ,(ly:make-pitch -1 0 SEMI-SHARP)) + (dod . ,(ly:make-pitch -1 0 SHARP)) + (dodsd . ,(ly:make-pitch -1 0 THREE-Q-SHARP)) + (dodd . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) + + (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) + (rebsb . ,(ly:make-pitch -1 1 THREE-Q-FLAT)) + (reb . ,(ly:make-pitch -1 1 FLAT)) + (resb . ,(ly:make-pitch -1 1 SEMI-FLAT)) + (re . ,(ly:make-pitch -1 1 NATURAL)) + (resd . ,(ly:make-pitch -1 1 SEMI-SHARP)) + (red . ,(ly:make-pitch -1 1 SHARP)) + (redsd . ,(ly:make-pitch -1 1 THREE-Q-SHARP)) + (redd . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) + + (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) + (mibsb . ,(ly:make-pitch -1 2 THREE-Q-FLAT)) + (mib . ,(ly:make-pitch -1 2 FLAT)) + (misb . ,(ly:make-pitch -1 2 SEMI-FLAT)) + (mi . ,(ly:make-pitch -1 2 NATURAL)) + (misd . ,(ly:make-pitch -1 2 SEMI-SHARP)) + (mid . ,(ly:make-pitch -1 2 SHARP)) + (midsd . ,(ly:make-pitch -1 2 THREE-Q-SHARP)) + (midd . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) + + (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) + (fabsb . ,(ly:make-pitch -1 3 THREE-Q-FLAT)) + (fab . ,(ly:make-pitch -1 3 FLAT)) + (fasb . ,(ly:make-pitch -1 3 SEMI-FLAT)) + (fa . ,(ly:make-pitch -1 3 NATURAL)) + (fasd . ,(ly:make-pitch -1 3 SEMI-SHARP)) + (fad . ,(ly:make-pitch -1 3 SHARP)) + (fadsd . ,(ly:make-pitch -1 3 THREE-Q-SHARP)) + (fadd . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) + + (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) + (solbsb . ,(ly:make-pitch -1 4 THREE-Q-FLAT)) + (solb . ,(ly:make-pitch -1 4 FLAT)) + (solsb . ,(ly:make-pitch -1 4 SEMI-FLAT)) + (sol . ,(ly:make-pitch -1 4 NATURAL)) + (solsd . ,(ly:make-pitch -1 4 SEMI-SHARP)) + (sold . ,(ly:make-pitch -1 4 SHARP)) + (soldsd . ,(ly:make-pitch -1 4 THREE-Q-SHARP)) + (soldd . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) + + (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) + (labsb . ,(ly:make-pitch -1 5 THREE-Q-FLAT)) + (lab . ,(ly:make-pitch -1 5 FLAT)) + (lasb . ,(ly:make-pitch -1 5 SEMI-FLAT)) + (la . ,(ly:make-pitch -1 5 NATURAL)) + (lasd . ,(ly:make-pitch -1 5 SEMI-SHARP)) + (lad . ,(ly:make-pitch -1 5 SHARP)) + (ladsd . ,(ly:make-pitch -1 5 THREE-Q-SHARP)) + (ladd . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) + + (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) + (sibsb . ,(ly:make-pitch -1 6 THREE-Q-FLAT)) + (sib . ,(ly:make-pitch -1 6 FLAT)) + (sisb . ,(ly:make-pitch -1 6 SEMI-FLAT)) + (si . ,(ly:make-pitch -1 6 NATURAL)) + (sisd . ,(ly:make-pitch -1 6 SEMI-SHARP)) + (sid . ,(ly:make-pitch -1 6 SHARP)) + (sidsd . ,(ly:make-pitch -1 6 THREE-Q-SHARP)) + (sidd . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) + + )) ;; Language: Norsk -------------------------------------------------; @@ -631,79 +631,79 @@ ;; Norwegian: c d e f g a b h (norsk . ( - (ceses . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) - (cessess . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) - (ces . ,(ly:make-pitch -1 0 FLAT)) - (cess . ,(ly:make-pitch -1 0 FLAT)) - (c . ,(ly:make-pitch -1 0 NATURAL)) - (cis . ,(ly:make-pitch -1 0 SHARP)) - (ciss . ,(ly:make-pitch -1 0 SHARP)) - (cisis . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) - (cississ . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) - (deses . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) - (dessess . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) - (des . ,(ly:make-pitch -1 1 FLAT)) - (dess . ,(ly:make-pitch -1 1 FLAT)) - (d . ,(ly:make-pitch -1 1 NATURAL)) - (dis . ,(ly:make-pitch -1 1 SHARP)) - (diss . ,(ly:make-pitch -1 1 SHARP)) - (disis . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) - (dississ . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) - (eeses . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) - (eessess . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) - (eses . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) - (essess . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) - (ees . ,(ly:make-pitch -1 2 FLAT)) - (eess . ,(ly:make-pitch -1 2 FLAT)) - (es . ,(ly:make-pitch -1 2 FLAT)) - (ess . ,(ly:make-pitch -1 2 FLAT)) - (e . ,(ly:make-pitch -1 2 NATURAL)) - (eis . ,(ly:make-pitch -1 2 SHARP)) - (eiss . ,(ly:make-pitch -1 2 SHARP)) - (eisis . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) - (eississ . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) - (feses . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) - (fessess . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) - (fes . ,(ly:make-pitch -1 3 FLAT)) - (fess . ,(ly:make-pitch -1 3 FLAT)) - (f . ,(ly:make-pitch -1 3 NATURAL)) - (fis . ,(ly:make-pitch -1 3 SHARP)) - (fiss . ,(ly:make-pitch -1 3 SHARP)) - (fisis . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) - (fississ . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) - (geses . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) - (gessess . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) - (ges . ,(ly:make-pitch -1 4 FLAT)) - (gess . ,(ly:make-pitch -1 4 FLAT)) - (g . ,(ly:make-pitch -1 4 NATURAL)) - (g . ,(ly:make-pitch -1 4 NATURAL)) - (gis . ,(ly:make-pitch -1 4 SHARP)) - (giss . ,(ly:make-pitch -1 4 SHARP)) - (gisis . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) - (gississ . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) - (aeses . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) - (aessess . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) - (ases . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) - (assess . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) - (aes . ,(ly:make-pitch -1 5 FLAT)) - (aess . ,(ly:make-pitch -1 5 FLAT)) - (as . ,(ly:make-pitch -1 5 FLAT)) - (ass . ,(ly:make-pitch -1 5 FLAT)) - (a . ,(ly:make-pitch -1 5 NATURAL)) - (ais . ,(ly:make-pitch -1 5 SHARP)) - (aiss . ,(ly:make-pitch -1 5 SHARP)) - (aisis . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) - (aississ . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) - (bes . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) - (bess . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) - (b . ,(ly:make-pitch -1 6 FLAT)) - (b . ,(ly:make-pitch -1 6 FLAT)) - (h . ,(ly:make-pitch -1 6 NATURAL)) - (his . ,(ly:make-pitch -1 6 SHARP)) - (hiss . ,(ly:make-pitch -1 6 SHARP)) - (hisis . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) - (hississ . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) - )) + (ceses . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) + (cessess . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) + (ces . ,(ly:make-pitch -1 0 FLAT)) + (cess . ,(ly:make-pitch -1 0 FLAT)) + (c . ,(ly:make-pitch -1 0 NATURAL)) + (cis . ,(ly:make-pitch -1 0 SHARP)) + (ciss . ,(ly:make-pitch -1 0 SHARP)) + (cisis . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) + (cississ . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) + (deses . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) + (dessess . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) + (des . ,(ly:make-pitch -1 1 FLAT)) + (dess . ,(ly:make-pitch -1 1 FLAT)) + (d . ,(ly:make-pitch -1 1 NATURAL)) + (dis . ,(ly:make-pitch -1 1 SHARP)) + (diss . ,(ly:make-pitch -1 1 SHARP)) + (disis . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) + (dississ . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) + (eeses . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) + (eessess . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) + (eses . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) + (essess . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) + (ees . ,(ly:make-pitch -1 2 FLAT)) + (eess . ,(ly:make-pitch -1 2 FLAT)) + (es . ,(ly:make-pitch -1 2 FLAT)) + (ess . ,(ly:make-pitch -1 2 FLAT)) + (e . ,(ly:make-pitch -1 2 NATURAL)) + (eis . ,(ly:make-pitch -1 2 SHARP)) + (eiss . ,(ly:make-pitch -1 2 SHARP)) + (eisis . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) + (eississ . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) + (feses . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) + (fessess . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) + (fes . ,(ly:make-pitch -1 3 FLAT)) + (fess . ,(ly:make-pitch -1 3 FLAT)) + (f . ,(ly:make-pitch -1 3 NATURAL)) + (fis . ,(ly:make-pitch -1 3 SHARP)) + (fiss . ,(ly:make-pitch -1 3 SHARP)) + (fisis . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) + (fississ . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) + (geses . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) + (gessess . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) + (ges . ,(ly:make-pitch -1 4 FLAT)) + (gess . ,(ly:make-pitch -1 4 FLAT)) + (g . ,(ly:make-pitch -1 4 NATURAL)) + (g . ,(ly:make-pitch -1 4 NATURAL)) + (gis . ,(ly:make-pitch -1 4 SHARP)) + (giss . ,(ly:make-pitch -1 4 SHARP)) + (gisis . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) + (gississ . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) + (aeses . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) + (aessess . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) + (ases . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) + (assess . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) + (aes . ,(ly:make-pitch -1 5 FLAT)) + (aess . ,(ly:make-pitch -1 5 FLAT)) + (as . ,(ly:make-pitch -1 5 FLAT)) + (ass . ,(ly:make-pitch -1 5 FLAT)) + (a . ,(ly:make-pitch -1 5 NATURAL)) + (ais . ,(ly:make-pitch -1 5 SHARP)) + (aiss . ,(ly:make-pitch -1 5 SHARP)) + (aisis . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) + (aississ . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) + (bes . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) + (bess . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) + (b . ,(ly:make-pitch -1 6 FLAT)) + (b . ,(ly:make-pitch -1 6 FLAT)) + (h . ,(ly:make-pitch -1 6 NATURAL)) + (his . ,(ly:make-pitch -1 6 SHARP)) + (hiss . ,(ly:make-pitch -1 6 SHARP)) + (hisis . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) + (hississ . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) + )) ;; Language: Portugues ---------------------------------------------; @@ -723,77 +723,77 @@ ;; Portuguese: do re mi fa sol la si (portugues . ( - (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) - (dobtqt . ,(ly:make-pitch -1 0 THREE-Q-FLAT)) - (dob . ,(ly:make-pitch -1 0 FLAT)) - (dobqt . ,(ly:make-pitch -1 0 SEMI-FLAT)) - (do . ,(ly:make-pitch -1 0 NATURAL)) - (dosqt . ,(ly:make-pitch -1 0 SEMI-SHARP)) - (dos . ,(ly:make-pitch -1 0 SHARP)) - (dostqt . ,(ly:make-pitch -1 0 THREE-Q-SHARP)) - (doss . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) - - (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) - (rebtqt . ,(ly:make-pitch -1 1 THREE-Q-FLAT)) - (reb . ,(ly:make-pitch -1 1 FLAT)) - (rebqt . ,(ly:make-pitch -1 1 SEMI-FLAT)) - (re . ,(ly:make-pitch -1 1 NATURAL)) - (resqt . ,(ly:make-pitch -1 1 SEMI-SHARP)) - (res . ,(ly:make-pitch -1 1 SHARP)) - (restqt . ,(ly:make-pitch -1 1 THREE-Q-SHARP)) - (ress . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) - - (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) - (mibtqt . ,(ly:make-pitch -1 2 THREE-Q-FLAT)) - (mib . ,(ly:make-pitch -1 2 FLAT)) - (mibqt . ,(ly:make-pitch -1 2 SEMI-FLAT)) - (mi . ,(ly:make-pitch -1 2 NATURAL)) - (misqt . ,(ly:make-pitch -1 2 SEMI-SHARP)) - (mis . ,(ly:make-pitch -1 2 SHARP)) - (mistqt . ,(ly:make-pitch -1 2 THREE-Q-SHARP)) - (miss . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) - - (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) - (fabtqt . ,(ly:make-pitch -1 3 THREE-Q-FLAT)) - (fab . ,(ly:make-pitch -1 3 FLAT)) - (fabqt . ,(ly:make-pitch -1 3 SEMI-FLAT)) - (fa . ,(ly:make-pitch -1 3 NATURAL)) - (fasqt . ,(ly:make-pitch -1 3 SEMI-SHARP)) - (fas . ,(ly:make-pitch -1 3 SHARP)) - (fastqt . ,(ly:make-pitch -1 3 THREE-Q-SHARP)) - (fass . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) - - (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) - (solbtqt . ,(ly:make-pitch -1 4 THREE-Q-FLAT)) - (solb . ,(ly:make-pitch -1 4 FLAT)) - (solbqt . ,(ly:make-pitch -1 4 SEMI-FLAT)) - (sol . ,(ly:make-pitch -1 4 NATURAL)) - (solsqt . ,(ly:make-pitch -1 4 SEMI-SHARP)) - (sols . ,(ly:make-pitch -1 4 SHARP)) - (solstqt . ,(ly:make-pitch -1 4 THREE-Q-SHARP)) - (solss . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) - - (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) - (labtqt . ,(ly:make-pitch -1 5 THREE-Q-FLAT)) - (lab . ,(ly:make-pitch -1 5 FLAT)) - (labqt . ,(ly:make-pitch -1 5 SEMI-FLAT)) - (la . ,(ly:make-pitch -1 5 NATURAL)) - (lasqt . ,(ly:make-pitch -1 5 SEMI-SHARP)) - (las . ,(ly:make-pitch -1 5 SHARP)) - (lastqt . ,(ly:make-pitch -1 5 THREE-Q-SHARP)) - (lass . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) - - (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) - (sibtqt . ,(ly:make-pitch -1 6 THREE-Q-FLAT)) - (sib . ,(ly:make-pitch -1 6 FLAT)) - (sibqt . ,(ly:make-pitch -1 6 SEMI-FLAT)) - (si . ,(ly:make-pitch -1 6 NATURAL)) - (sisqt . ,(ly:make-pitch -1 6 SEMI-SHARP)) - (sis . ,(ly:make-pitch -1 6 SHARP)) - (sistqt . ,(ly:make-pitch -1 6 THREE-Q-SHARP)) - (siss . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) - - )) + (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) + (dobtqt . ,(ly:make-pitch -1 0 THREE-Q-FLAT)) + (dob . ,(ly:make-pitch -1 0 FLAT)) + (dobqt . ,(ly:make-pitch -1 0 SEMI-FLAT)) + (do . ,(ly:make-pitch -1 0 NATURAL)) + (dosqt . ,(ly:make-pitch -1 0 SEMI-SHARP)) + (dos . ,(ly:make-pitch -1 0 SHARP)) + (dostqt . ,(ly:make-pitch -1 0 THREE-Q-SHARP)) + (doss . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) + + (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) + (rebtqt . ,(ly:make-pitch -1 1 THREE-Q-FLAT)) + (reb . ,(ly:make-pitch -1 1 FLAT)) + (rebqt . ,(ly:make-pitch -1 1 SEMI-FLAT)) + (re . ,(ly:make-pitch -1 1 NATURAL)) + (resqt . ,(ly:make-pitch -1 1 SEMI-SHARP)) + (res . ,(ly:make-pitch -1 1 SHARP)) + (restqt . ,(ly:make-pitch -1 1 THREE-Q-SHARP)) + (ress . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) + + (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) + (mibtqt . ,(ly:make-pitch -1 2 THREE-Q-FLAT)) + (mib . ,(ly:make-pitch -1 2 FLAT)) + (mibqt . ,(ly:make-pitch -1 2 SEMI-FLAT)) + (mi . ,(ly:make-pitch -1 2 NATURAL)) + (misqt . ,(ly:make-pitch -1 2 SEMI-SHARP)) + (mis . ,(ly:make-pitch -1 2 SHARP)) + (mistqt . ,(ly:make-pitch -1 2 THREE-Q-SHARP)) + (miss . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) + + (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) + (fabtqt . ,(ly:make-pitch -1 3 THREE-Q-FLAT)) + (fab . ,(ly:make-pitch -1 3 FLAT)) + (fabqt . ,(ly:make-pitch -1 3 SEMI-FLAT)) + (fa . ,(ly:make-pitch -1 3 NATURAL)) + (fasqt . ,(ly:make-pitch -1 3 SEMI-SHARP)) + (fas . ,(ly:make-pitch -1 3 SHARP)) + (fastqt . ,(ly:make-pitch -1 3 THREE-Q-SHARP)) + (fass . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) + + (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) + (solbtqt . ,(ly:make-pitch -1 4 THREE-Q-FLAT)) + (solb . ,(ly:make-pitch -1 4 FLAT)) + (solbqt . ,(ly:make-pitch -1 4 SEMI-FLAT)) + (sol . ,(ly:make-pitch -1 4 NATURAL)) + (solsqt . ,(ly:make-pitch -1 4 SEMI-SHARP)) + (sols . ,(ly:make-pitch -1 4 SHARP)) + (solstqt . ,(ly:make-pitch -1 4 THREE-Q-SHARP)) + (solss . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) + + (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) + (labtqt . ,(ly:make-pitch -1 5 THREE-Q-FLAT)) + (lab . ,(ly:make-pitch -1 5 FLAT)) + (labqt . ,(ly:make-pitch -1 5 SEMI-FLAT)) + (la . ,(ly:make-pitch -1 5 NATURAL)) + (lasqt . ,(ly:make-pitch -1 5 SEMI-SHARP)) + (las . ,(ly:make-pitch -1 5 SHARP)) + (lastqt . ,(ly:make-pitch -1 5 THREE-Q-SHARP)) + (lass . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) + + (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) + (sibtqt . ,(ly:make-pitch -1 6 THREE-Q-FLAT)) + (sib . ,(ly:make-pitch -1 6 FLAT)) + (sibqt . ,(ly:make-pitch -1 6 SEMI-FLAT)) + (si . ,(ly:make-pitch -1 6 NATURAL)) + (sisqt . ,(ly:make-pitch -1 6 SEMI-SHARP)) + (sis . ,(ly:make-pitch -1 6 SHARP)) + (sistqt . ,(ly:make-pitch -1 6 THREE-Q-SHARP)) + (siss . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) + + )) ;; Language: Suomi -------------------------------------------------; @@ -809,45 +809,45 @@ ;; Finnish: c d e f g a b h (suomi . ( - (ceses . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) - (ces . ,(ly:make-pitch -1 0 FLAT)) - (c . ,(ly:make-pitch -1 0 NATURAL)) - (cis . ,(ly:make-pitch -1 0 SHARP)) - (cisis . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) - (deses . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) - (des . ,(ly:make-pitch -1 1 FLAT)) - (d . ,(ly:make-pitch -1 1 NATURAL)) - (dis . ,(ly:make-pitch -1 1 SHARP)) - (disis . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) - (eses . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) - (es . ,(ly:make-pitch -1 2 FLAT)) - (e . ,(ly:make-pitch -1 2 NATURAL)) - (eis . ,(ly:make-pitch -1 2 SHARP)) - (eisis . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) - (feses . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) - (fes . ,(ly:make-pitch -1 3 FLAT)) - (f . ,(ly:make-pitch -1 3 NATURAL)) - (fis . ,(ly:make-pitch -1 3 SHARP)) - (fisis . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) - (geses . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) - (ges . ,(ly:make-pitch -1 4 FLAT)) - (g . ,(ly:make-pitch -1 4 NATURAL)) - (gis . ,(ly:make-pitch -1 4 SHARP)) - (gisis . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) - (asas . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) - (ases . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) ;;non-standard name for asas - (as . ,(ly:make-pitch -1 5 FLAT)) - (a . ,(ly:make-pitch -1 5 NATURAL)) - (ais . ,(ly:make-pitch -1 5 SHARP)) - (aisis . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) - (bb . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) ;; should be bes. Kept for downwards compatibility - (bes . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) - (heses . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) ;;non-standard name for bb - (b . ,(ly:make-pitch -1 6 FLAT)) - (h . ,(ly:make-pitch -1 6 NATURAL)) - (his . ,(ly:make-pitch -1 6 SHARP)) - (hisis . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) - )) + (ceses . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) + (ces . ,(ly:make-pitch -1 0 FLAT)) + (c . ,(ly:make-pitch -1 0 NATURAL)) + (cis . ,(ly:make-pitch -1 0 SHARP)) + (cisis . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) + (deses . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) + (des . ,(ly:make-pitch -1 1 FLAT)) + (d . ,(ly:make-pitch -1 1 NATURAL)) + (dis . ,(ly:make-pitch -1 1 SHARP)) + (disis . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) + (eses . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) + (es . ,(ly:make-pitch -1 2 FLAT)) + (e . ,(ly:make-pitch -1 2 NATURAL)) + (eis . ,(ly:make-pitch -1 2 SHARP)) + (eisis . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) + (feses . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) + (fes . ,(ly:make-pitch -1 3 FLAT)) + (f . ,(ly:make-pitch -1 3 NATURAL)) + (fis . ,(ly:make-pitch -1 3 SHARP)) + (fisis . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) + (geses . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) + (ges . ,(ly:make-pitch -1 4 FLAT)) + (g . ,(ly:make-pitch -1 4 NATURAL)) + (gis . ,(ly:make-pitch -1 4 SHARP)) + (gisis . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) + (asas . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) + (ases . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) ;;non-standard name for asas + (as . ,(ly:make-pitch -1 5 FLAT)) + (a . ,(ly:make-pitch -1 5 NATURAL)) + (ais . ,(ly:make-pitch -1 5 SHARP)) + (aisis . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) + (bb . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) ;; should be bes. Kept for downwards compatibility + (bes . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) + (heses . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) ;;non-standard name for bb + (b . ,(ly:make-pitch -1 6 FLAT)) + (h . ,(ly:make-pitch -1 6 NATURAL)) + (his . ,(ly:make-pitch -1 6 SHARP)) + (hisis . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) + )) ;; Language: Svenska -----------------------------------------------; @@ -863,42 +863,42 @@ ;; Swedish: c d e f g a b h (svenska . ( - (cessess . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) - (cess . ,(ly:make-pitch -1 0 FLAT)) - (c . ,(ly:make-pitch -1 0 NATURAL)) - (ciss . ,(ly:make-pitch -1 0 SHARP)) - (cississ . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) - (dessess . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) - (dess . ,(ly:make-pitch -1 1 FLAT)) - (d . ,(ly:make-pitch -1 1 NATURAL)) - (diss . ,(ly:make-pitch -1 1 SHARP)) - (dississ . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) - (essess . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) - (ess . ,(ly:make-pitch -1 2 FLAT)) - (e . ,(ly:make-pitch -1 2 NATURAL)) - (eiss . ,(ly:make-pitch -1 2 SHARP)) - (eississ . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) - (fessess . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) - (fess . ,(ly:make-pitch -1 3 FLAT)) - (f . ,(ly:make-pitch -1 3 NATURAL)) - (fiss . ,(ly:make-pitch -1 3 SHARP)) - (fississ . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) - (gessess . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) - (gess . ,(ly:make-pitch -1 4 FLAT)) - (g . ,(ly:make-pitch -1 4 NATURAL)) - (giss . ,(ly:make-pitch -1 4 SHARP)) - (gississ . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) - (assess . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) - (ass . ,(ly:make-pitch -1 5 FLAT)) - (a . ,(ly:make-pitch -1 5 NATURAL)) - (aiss . ,(ly:make-pitch -1 5 SHARP)) - (aississ . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) - (hessess . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) - (b . ,(ly:make-pitch -1 6 FLAT)) - (h . ,(ly:make-pitch -1 6 NATURAL)) - (hiss . ,(ly:make-pitch -1 6 SHARP)) - (hississ . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) - )) + (cessess . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) + (cess . ,(ly:make-pitch -1 0 FLAT)) + (c . ,(ly:make-pitch -1 0 NATURAL)) + (ciss . ,(ly:make-pitch -1 0 SHARP)) + (cississ . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) + (dessess . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) + (dess . ,(ly:make-pitch -1 1 FLAT)) + (d . ,(ly:make-pitch -1 1 NATURAL)) + (diss . ,(ly:make-pitch -1 1 SHARP)) + (dississ . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) + (essess . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) + (ess . ,(ly:make-pitch -1 2 FLAT)) + (e . ,(ly:make-pitch -1 2 NATURAL)) + (eiss . ,(ly:make-pitch -1 2 SHARP)) + (eississ . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) + (fessess . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) + (fess . ,(ly:make-pitch -1 3 FLAT)) + (f . ,(ly:make-pitch -1 3 NATURAL)) + (fiss . ,(ly:make-pitch -1 3 SHARP)) + (fississ . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) + (gessess . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) + (gess . ,(ly:make-pitch -1 4 FLAT)) + (g . ,(ly:make-pitch -1 4 NATURAL)) + (giss . ,(ly:make-pitch -1 4 SHARP)) + (gississ . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) + (assess . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) + (ass . ,(ly:make-pitch -1 5 FLAT)) + (a . ,(ly:make-pitch -1 5 NATURAL)) + (aiss . ,(ly:make-pitch -1 5 SHARP)) + (aississ . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) + (hessess . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) + (b . ,(ly:make-pitch -1 6 FLAT)) + (h . ,(ly:make-pitch -1 6 NATURAL)) + (hiss . ,(ly:make-pitch -1 6 SHARP)) + (hississ . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) + )) ;; Language: Vlaams ------------------------------------------------; @@ -914,48 +914,48 @@ ;; Flemish: do re mi fa sol la si (vlaams . ( - (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) - (dob . ,(ly:make-pitch -1 0 FLAT)) - (do . ,(ly:make-pitch -1 0 NATURAL)) - (dok . ,(ly:make-pitch -1 0 SHARP)) - (dokk . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) - - (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) - (reb . ,(ly:make-pitch -1 1 FLAT)) - (re . ,(ly:make-pitch -1 1 NATURAL)) - (rek . ,(ly:make-pitch -1 1 SHARP)) - (rekk . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) - - (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) - (mib . ,(ly:make-pitch -1 2 FLAT)) - (mi . ,(ly:make-pitch -1 2 NATURAL)) - (mik . ,(ly:make-pitch -1 2 SHARP)) - (mikk . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) - - (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) - (fab . ,(ly:make-pitch -1 3 FLAT)) - (fa . ,(ly:make-pitch -1 3 NATURAL)) - (fak . ,(ly:make-pitch -1 3 SHARP)) - (fakk . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) - - (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) - (solb . ,(ly:make-pitch -1 4 FLAT)) - (sol . ,(ly:make-pitch -1 4 NATURAL)) - (solk . ,(ly:make-pitch -1 4 SHARP)) - (solkk . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) - - (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) - (lab . ,(ly:make-pitch -1 5 FLAT)) - (la . ,(ly:make-pitch -1 5 NATURAL)) - (lak . ,(ly:make-pitch -1 5 SHARP)) - (lakk . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) - - (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) - (sib . ,(ly:make-pitch -1 6 FLAT)) - (si . ,(ly:make-pitch -1 6 NATURAL)) - (sik . ,(ly:make-pitch -1 6 SHARP)) - (sikk . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) - )) + (dobb . ,(ly:make-pitch -1 0 DOUBLE-FLAT)) + (dob . ,(ly:make-pitch -1 0 FLAT)) + (do . ,(ly:make-pitch -1 0 NATURAL)) + (dok . ,(ly:make-pitch -1 0 SHARP)) + (dokk . ,(ly:make-pitch -1 0 DOUBLE-SHARP)) + + (rebb . ,(ly:make-pitch -1 1 DOUBLE-FLAT)) + (reb . ,(ly:make-pitch -1 1 FLAT)) + (re . ,(ly:make-pitch -1 1 NATURAL)) + (rek . ,(ly:make-pitch -1 1 SHARP)) + (rekk . ,(ly:make-pitch -1 1 DOUBLE-SHARP)) + + (mibb . ,(ly:make-pitch -1 2 DOUBLE-FLAT)) + (mib . ,(ly:make-pitch -1 2 FLAT)) + (mi . ,(ly:make-pitch -1 2 NATURAL)) + (mik . ,(ly:make-pitch -1 2 SHARP)) + (mikk . ,(ly:make-pitch -1 2 DOUBLE-SHARP)) + + (fabb . ,(ly:make-pitch -1 3 DOUBLE-FLAT)) + (fab . ,(ly:make-pitch -1 3 FLAT)) + (fa . ,(ly:make-pitch -1 3 NATURAL)) + (fak . ,(ly:make-pitch -1 3 SHARP)) + (fakk . ,(ly:make-pitch -1 3 DOUBLE-SHARP)) + + (solbb . ,(ly:make-pitch -1 4 DOUBLE-FLAT)) + (solb . ,(ly:make-pitch -1 4 FLAT)) + (sol . ,(ly:make-pitch -1 4 NATURAL)) + (solk . ,(ly:make-pitch -1 4 SHARP)) + (solkk . ,(ly:make-pitch -1 4 DOUBLE-SHARP)) + + (labb . ,(ly:make-pitch -1 5 DOUBLE-FLAT)) + (lab . ,(ly:make-pitch -1 5 FLAT)) + (la . ,(ly:make-pitch -1 5 NATURAL)) + (lak . ,(ly:make-pitch -1 5 SHARP)) + (lakk . ,(ly:make-pitch -1 5 DOUBLE-SHARP)) + + (sibb . ,(ly:make-pitch -1 6 DOUBLE-FLAT)) + (sib . ,(ly:make-pitch -1 6 FLAT)) + (si . ,(ly:make-pitch -1 6 NATURAL)) + (sik . ,(ly:make-pitch -1 6 SHARP)) + (sikk . ,(ly:make-pitch -1 6 DOUBLE-SHARP)) + )) )) ;; add two native utf-8 aliases. Pairs obey cp-like order: '(old new) @@ -970,11 +970,11 @@ (define-public (note-names-language parser str) (_ "Select note names language.") (let ((alist (assoc-get (string->symbol str) - language-pitch-names - '()))) + language-pitch-names + '()))) (if (pair? alist) - (begin - (ly:debug (_ "Using `~a' note names...") str) - (set! pitchnames alist) - (ly:parser-set-note-names parser alist)) - (ly:warning (_ "Could not find language `~a'. Ignoring.") str)))) + (begin + (ly:debug (_ "Using `~a' note names...") str) + (set! pitchnames alist) + (ly:parser-set-note-names parser alist)) + (ly:warning (_ "Could not find language `~a'. Ignoring.") str)))) diff --git a/scm/define-stencil-commands.scm b/scm/define-stencil-commands.scm index fddd6855b2..dffb578c6e 100644 --- a/scm/define-stencil-commands.scm +++ b/scm/define-stencil-commands.scm @@ -70,5 +70,5 @@ are used internally in @file{lily/@/stencil-interpret.cc}." )) (map ly:register-stencil-expression - (append (ly:all-stencil-commands) - (ly:all-output-backend-commands))) + (append (ly:all-stencil-commands) + (ly:all-output-backend-commands))) diff --git a/scm/define-woodwind-diagrams.scm b/scm/define-woodwind-diagrams.scm index 513fca520d..cffe25c07d 100644 --- a/scm/define-woodwind-diagrams.scm +++ b/scm/define-woodwind-diagrams.scm @@ -34,10 +34,10 @@ are provided in @var{function-list}. Example: Executing @samp{(function-chain 1 `((,+ 1) (,- 2) (,+ 3) (,/)))} returns @samp{1/3}." (if (null? function-list) - arg - (function-chain - (apply (caar function-list) (append `(,arg) (cdar function-list))) - (cdr function-list)))) + arg + (function-chain + (apply (caar function-list) (append `(,arg) (cdar function-list))) + (cdr function-list)))) (define (rotunda-map function inlist rotunda) "Like map, but with a rotating last argument to function. @@ -46,12 +46,12 @@ returns @samp{1/3}." @code{(2 -8 4 -6)}" (define (rotunda-map-chain function inlist outlist rotunda) (if (null? inlist) - outlist - (rotunda-map-chain - function - (cdr inlist) - (append outlist (list (function (car inlist) (car rotunda)))) - (append (cdr rotunda) (list (car rotunda)))))) + outlist + (rotunda-map-chain + function + (cdr inlist) + (append outlist (list (function (car inlist) (car rotunda)))) + (append (cdr rotunda) (list (car rotunda)))))) (rotunda-map-chain function inlist '() rotunda)) (define (assoc-keys alist) @@ -68,9 +68,9 @@ returns @samp{1/3}." @code{(get-slope-offset '(1 . 2) '(3 . -5.1))} @code{(-3.55 . 5.55)}" (let* - ((slope (/ (- (cdr p1) (cdr p2)) (- (car p1) (car p2)))) - (offset (- (cdr p1) (* slope (car p1))))) - `(,slope . ,offset))) + ((slope (/ (- (cdr p1) (cdr p2)) (- (car p1) (car p2)))) + (offset (- (cdr p1) (* slope (car p1))))) + `(,slope . ,offset))) (define (is-square? x input-list) "Returns true if x is the square of a value in input-list." @@ -97,17 +97,17 @@ returns @samp{1/3}." ;; Translates a "normal" key (open, closed, trill) (define (key-fill-translate fill) (cond - ((= fill 1) #f) - ((= fill 2) #f) - ((= fill (expt (assoc-get 'F HOLE-FILL-LIST) 2)) 0.5) - ((= fill (assoc-get 'F HOLE-FILL-LIST)) #t))) + ((= fill 1) #f) + ((= fill 2) #f) + ((= fill (expt (assoc-get 'F HOLE-FILL-LIST) 2)) 0.5) + ((= fill (assoc-get 'F HOLE-FILL-LIST)) #t))) ;; Similar to above, but trans vs opaque doesn't matter (define (text-fill-translate fill) (cond - ((< fill 3) 1.0) - ((= fill (expt (assoc-get 'F HOLE-FILL-LIST) 2)) 0.5) - ((= fill (assoc-get 'F HOLE-FILL-LIST)) 0.0))) + ((< fill 3) 1.0) + ((= fill (expt (assoc-get 'F HOLE-FILL-LIST) 2)) 0.5) + ((= fill (assoc-get 'F HOLE-FILL-LIST)) 0.0))) ;; Emits a list for the central-column-hole maker ;; (not-full?, 1-quarter-full?, 1-half-full?, 3-quarters-full?, full?) @@ -115,8 +115,8 @@ returns @samp{1/3}." ;; not-full and 3-quarters-full (define (process-fill-value fill) (let* ((avals (list-tail (assoc-values HOLE-FILL-LIST) 1))) - (append `(,(or (< fill 3) (is-square? fill avals))) - (map (lambda (x) (= 0 (remainder fill x))) avals)))) + (append `(,(or (< fill 3) (is-square? fill avals))) + (map (lambda (x) (= 0 (remainder fill x))) avals)))) ;; Color a stencil gray (define (gray-colorize stencil) @@ -126,26 +126,26 @@ returns @samp{1/3}." (define (rich-path-stencil ls x-stretch y-stretch proc) (lambda (radius thick fill layout props) (let* - ((fill-translate (key-fill-translate fill)) - (gray? (eqv? fill-translate 0.5))) - (ly:stencil-add - ((if gray? gray-colorize identity) - (proc - (make-connected-path-stencil - ls - thick - (* x-stretch radius) - (* y-stretch radius) - #f - (if gray? #t fill-translate)))) - (if (not gray?) - empty-stencil - ((rich-path-stencil ls x-stretch y-stretch proc) - radius - thick - 1 - layout - props)))))) + ((fill-translate (key-fill-translate fill)) + (gray? (eqv? fill-translate 0.5))) + (ly:stencil-add + ((if gray? gray-colorize identity) + (proc + (make-connected-path-stencil + ls + thick + (* x-stretch radius) + (* y-stretch radius) + #f + (if gray? #t fill-translate)))) + (if (not gray?) + empty-stencil + ((rich-path-stencil ls x-stretch y-stretch proc) + radius + thick + 1 + layout + props)))))) ;; A connected path stencil without a surrounding proc (define (standard-path-stencil ls x-stretch y-stretch) @@ -155,49 +155,49 @@ returns @samp{1/3}." (define (rich-pe-stencil x-stretch y-stretch start end proc) (lambda (radius thick fill layout props) (let* - ((fill-translate (key-fill-translate fill)) - (gray? (eqv? fill-translate 0.5))) - (ly:stencil-add - ((if gray? gray-colorize identity) - (proc - (make-partial-ellipse-stencil - (* x-stretch radius) - (* y-stretch radius) - start - end - thick - #t - (if gray? #t fill-translate)))) - (if (not gray?) - empty-stencil - ((rich-pe-stencil x-stretch y-stretch start end proc) - radius - thick - 1 - layout - props)))))) + ((fill-translate (key-fill-translate fill)) + (gray? (eqv? fill-translate 0.5))) + (ly:stencil-add + ((if gray? gray-colorize identity) + (proc + (make-partial-ellipse-stencil + (* x-stretch radius) + (* y-stretch radius) + start + end + thick + #t + (if gray? #t fill-translate)))) + (if (not gray?) + empty-stencil + ((rich-pe-stencil x-stretch y-stretch start end proc) + radius + thick + 1 + layout + props)))))) (define (rich-e-stencil x-stretch y-stretch proc) (lambda (radius thick fill layout props) (let* - ((fill-translate (key-fill-translate fill)) - (gray? (eqv? fill-translate 0.5))) - (ly:stencil-add - ((if gray? gray-colorize identity) - (proc - (make-ellipse-stencil + ((fill-translate (key-fill-translate fill)) + (gray? (eqv? fill-translate 0.5))) + (ly:stencil-add + ((if gray? gray-colorize identity) + (proc + (make-ellipse-stencil (* x-stretch radius) (* y-stretch radius) thick (if gray? #t fill-translate)))) - (if (not gray?) - empty-stencil - ((rich-e-stencil x-stretch y-stretch proc) - radius - thick - 1 - layout - props)))))) + (if (not gray?) + empty-stencil + ((rich-e-stencil x-stretch y-stretch proc) + radius + thick + 1 + layout + props)))))) ;; An ellipse stencil without a surrounding proc (define (standard-e-stencil x-stretch y-stretch) @@ -210,36 +210,36 @@ returns @samp{1/3}." (define (make-symbol-alist symbol simple? ring?) (filter (lambda (x) (not - (equal? - x - `(,(symbol-concatenate symbol 'T 'F) . - ,(expt (assoc-get 'F HOLE-FILL-LIST) 2))))) + (equal? + x + `(,(symbol-concatenate symbol 'T 'F) . + ,(expt (assoc-get 'F HOLE-FILL-LIST) 2))))) (append - `((,symbol . ,(assoc-get 'F HOLE-FILL-LIST)) - (,(symbol-concatenate symbol 'T) . - ,(expt (assoc-get 'F HOLE-FILL-LIST) 2))) - (if simple? - '() - (apply append - (map (lambda (x) - (append - `((,(symbol-concatenate symbol (car x) 'T) - . ,(expt (cdr x) 2)) - (,(symbol-concatenate symbol 'T (car x)) - . ,(* (cdr x) (assoc-get 'F HOLE-FILL-LIST))) - (,(symbol-concatenate symbol (car x)) - . ,(cdr x))) - (apply append - (map (lambda (y) - (map (lambda (a b) - `(,(symbol-concatenate symbol - (car a) - 'T - (car b)) - . ,(* (cdr a) (cdr b)))) - `(,x ,y) `(,y ,x))) - (cdr (member x HOLE-FILL-LIST)))))) - (if ring? HOLE-FILL-LIST (cdr HOLE-FILL-LIST)))))))) + `((,symbol . ,(assoc-get 'F HOLE-FILL-LIST)) + (,(symbol-concatenate symbol 'T) . + ,(expt (assoc-get 'F HOLE-FILL-LIST) 2))) + (if simple? + '() + (apply append + (map (lambda (x) + (append + `((,(symbol-concatenate symbol (car x) 'T) + . ,(expt (cdr x) 2)) + (,(symbol-concatenate symbol 'T (car x)) + . ,(* (cdr x) (assoc-get 'F HOLE-FILL-LIST))) + (,(symbol-concatenate symbol (car x)) + . ,(cdr x))) + (apply append + (map (lambda (y) + (map (lambda (a b) + `(,(symbol-concatenate symbol + (car a) + 'T + (car b)) + . ,(* (cdr a) (cdr b)))) + `(,x ,y) `(,y ,x))) + (cdr (member x HOLE-FILL-LIST)))))) + (if ring? HOLE-FILL-LIST (cdr HOLE-FILL-LIST)))))))) ;;; Commands for text layout @@ -248,50 +248,50 @@ returns @samp{1/3}." (conditional-circle-markup layout props trigger in-markup) (number? markup?) (interpret-markup layout props - (if (eqv? trigger 0.5) - (markup #:circle (markup in-markup)) - (markup in-markup)))) + (if (eqv? trigger 0.5) + (markup #:circle (markup in-markup)) + (markup in-markup)))) ;; Makes a list of named-keys (define (make-name-keylist input-list key-list font-size) (map (lambda (x y) (if (< x 1) - (markup #:conditional-circle-markup - x - (make-concat-markup - (list - (markup #:abs-fontsize font-size (car y)) - (if (and (< x 1) (cdr y)) - (if (eqv? (cdr y) 1) - (markup - #:abs-fontsize - font-size - #:raise - 1 - #:fontsize - -2 - #:sharp) - (markup - #:abs-fontsize - font-size - #:raise - 1 - #:fontsize - -2 - #:flat)) - (markup #:null))))) - (markup #:null))) - input-list key-list)) + (markup #:conditional-circle-markup + x + (make-concat-markup + (list + (markup #:abs-fontsize font-size (car y)) + (if (and (< x 1) (cdr y)) + (if (eqv? (cdr y) 1) + (markup + #:abs-fontsize + font-size + #:raise + 1 + #:fontsize + -2 + #:sharp) + (markup + #:abs-fontsize + font-size + #:raise + 1 + #:fontsize + -2 + #:flat)) + (markup #:null))))) + (markup #:null))) + input-list key-list)) ;; Makes a list of number-keys (define (make-number-keylist input-list key-list font-size) (map (lambda (x y) (if (< x 1) - (markup - #:conditional-circle-markup - x - (markup #:abs-fontsize font-size #:number y)) - (markup #:null))) + (markup + #:conditional-circle-markup + x + (markup #:abs-fontsize font-size #:number y)) + (markup #:null))) input-list key-list)) @@ -299,35 +299,35 @@ returns @samp{1/3}." (define (aligned-text-stencil-function dir hv) (lambda (key-name-list radius fill-list layout props) (interpret-markup - layout - props - (make-general-align-markup - X - dir - ((if hv make-concat-markup make-center-column-markup) - (make-name-keylist - (map text-fill-translate fill-list) - key-name-list - (* 12 radius))))))) + layout + props + (make-general-align-markup + X + dir + ((if hv make-concat-markup make-center-column-markup) + (make-name-keylist + (map text-fill-translate fill-list) + key-name-list + (* 12 radius))))))) (define number-column-stencil (lambda (key-name-list radius fill-list layout props) (interpret-markup - layout - props + layout + props + (make-general-align-markup + Y + CENTER (make-general-align-markup - Y - CENTER - (make-general-align-markup - X - RIGHT - (make-override-markup - '(baseline-skip . 0) - (make-column-markup - (make-number-keylist - (map text-fill-translate fill-list) - key-name-list - (* radius 8))))))))) + X + RIGHT + (make-override-markup + '(baseline-skip . 0) + (make-column-markup + (make-number-keylist + (map text-fill-translate fill-list) + key-name-list + (* radius 8))))))))) ;; Utility function for the left-hand keys (define lh-woodwind-text-stencil @@ -344,17 +344,17 @@ returns @samp{1/3}." (define (rich-group-draw-rule alist target-part change-part) (if - (entry-greater-than-x? - (map (lambda (key) (assoc-get key alist)) target-part) 3) - (map-selected-alist-keys (lambda (x) (if (= x 0) 1 x)) change-part alist) - alist)) + (entry-greater-than-x? + (map (lambda (key) (assoc-get key alist)) target-part) 3) + (map-selected-alist-keys (lambda (x) (if (= x 0) 1 x)) change-part alist) + alist)) (define (bassoon-midline-rule alist target-part) (if - (entry-greater-than-x? - (map (lambda (key) (assoc-get key alist)) target-part) 0) - (map-selected-alist-keys (lambda (x) 1) '((hidden . long-midline)) alist) - (map-selected-alist-keys (lambda (x) 1) '((hidden . midline)) alist))) + (entry-greater-than-x? + (map (lambda (key) (assoc-get key alist)) target-part) 0) + (map-selected-alist-keys (lambda (x) 1) '((hidden . long-midline)) alist) + (map-selected-alist-keys (lambda (x) 1) '((hidden . midline)) alist))) (define (group-draw-rule alist target-part) (rich-group-draw-rule alist target-part target-part)) @@ -364,28 +364,28 @@ returns @samp{1/3}." (define (apply-group-draw-rule-series alist target-part-list) (if (null? target-part-list) - alist - (apply-group-draw-rule-series - (group-draw-rule alist (car target-part-list)) - (cdr target-part-list)))) + alist + (apply-group-draw-rule-series + (group-draw-rule alist (car target-part-list)) + (cdr target-part-list)))) ;; Extra-offset rules (define (rich-group-extra-offset-rule alist target-part change-part eos) (if - (entry-greater-than-x? - (map (lambda (key) (assoc-get key alist)) target-part) 0) - (map-selected-alist-keys (lambda (x) eos) change-part alist) - alist)) + (entry-greater-than-x? + (map (lambda (key) (assoc-get key alist)) target-part) 0) + (map-selected-alist-keys (lambda (x) eos) change-part alist) + alist)) (define (group-extra-offset-rule alist target-part eos) (rich-group-extra-offset-rule alist target-part target-part eos)) (define (uniform-extra-offset-rule alist eos) (map-selected-alist-keys - (lambda (x) (if (pair? x) x eos)) - (assoc-keys alist) - alist)) + (lambda (x) (if (pair? x) x eos)) + (assoc-keys alist) + alist)) ;;; General drawing commands @@ -402,29 +402,29 @@ returns @samp{1/3}." ;; Used for several upper keys in the clarinet and sax (define (upper-key-stencil tailw tailh bodyw bodyh) (let* - ((xmove (lambda (x) (+ tailw (+ 0.2 (* bodyw (- x 0.2)))))) - (ymove (lambda (x) (+ (- tailh) (+ -0.05 (* bodyh (+ x 0.05))))))) - (standard-path-stencil - `((,(xmove 0.7) - ,(ymove -0.2) - ,(xmove 1.0) - ,(ymove -1.0) - ,(xmove 0.5) - ,(ymove -1.0)) - (,(xmove 0.2) - ,(ymove -1.0) - ,(xmove 0.2) - ,(ymove -0.2) - ,(xmove 0.3) - ,(ymove -0.1)) - (,(+ 0.2 tailw) - ,(- -0.05 tailh) - ,(+ 0.1 (/ tailw 2)) - ,(- -0.025 (/ tailh 2)) - 0.0 - 0.0)) - 1.0 - 1.0))) + ((xmove (lambda (x) (+ tailw (+ 0.2 (* bodyw (- x 0.2)))))) + (ymove (lambda (x) (+ (- tailh) (+ -0.05 (* bodyh (+ x 0.05))))))) + (standard-path-stencil + `((,(xmove 0.7) + ,(ymove -0.2) + ,(xmove 1.0) + ,(ymove -1.0) + ,(xmove 0.5) + ,(ymove -1.0)) + (,(xmove 0.2) + ,(ymove -1.0) + ,(xmove 0.2) + ,(ymove -0.2) + ,(xmove 0.3) + ,(ymove -0.1)) + (,(+ 0.2 tailw) + ,(- -0.05 tailh) + ,(+ 0.1 (/ tailw 2)) + ,(- -0.025 (/ tailh 2)) + 0.0 + 0.0)) + 1.0 + 1.0))) ;; Utility function for the column-hole maker. ;; Returns the left and right degrees for the drawing of a given @@ -432,23 +432,23 @@ returns @samp{1/3}." (define (degree-first-true fill-list left? reverse?) (define (dfl-crawler fill-list os-list left?) (if (car fill-list) - ((if left? car cdr) (car os-list)) - (dfl-crawler (cdr fill-list) (cdr os-list) left?))) + ((if left? car cdr) (car os-list)) + (dfl-crawler (cdr fill-list) (cdr os-list) left?))) (dfl-crawler - ((if reverse? reverse identity) fill-list) - ((if reverse? reverse identity) - '((0 . 0) (215 . 325) (180 . 0) (145 . 35) (90 . 90))) - left?)) + ((if reverse? reverse identity) fill-list) + ((if reverse? reverse identity) + '((0 . 0) (215 . 325) (180 . 0) (145 . 35) (90 . 90))) + left?)) ;; Gets the position of the first (or last if reverse?) element of a list. (define (position-true-endpoint in-list reverse?) (define (pte-crawler in-list n) (if (car in-list) - n - (pte-crawler (cdr in-list) (+ n 1)))) + n + (pte-crawler (cdr in-list) (+ n 1)))) ((if reverse? - +) - (if reverse? (length in-list) 0) - (pte-crawler ((if reverse? reverse identity) in-list) 0))) + (if reverse? (length in-list) 0) + (pte-crawler ((if reverse? reverse identity) in-list) 0))) ;; Huge, kind-of-ugly maker of a circle in a column. ;; I think this is the clearest way to write it, though... @@ -456,57 +456,57 @@ returns @samp{1/3}." (define (column-circle-stencil radius thick fill layout props) (let* ((fill-list (process-fill-value fill))) (cond - ((and - (list-ref fill-list 0) - (not (true-entry? (list-tail fill-list 1)))) ; is it empty? - ((standard-e-stencil 1.0 1.0) radius thick fill layout props)) - ((and - (list-ref fill-list 4) - (not (true-entry? (list-head fill-list 4)))) ; is it full? - ((standard-e-stencil 1.0 1.0) radius thick fill layout props)) - ((and - (list-ref fill-list 0) - (list-ref fill-list 4)) ; is it a trill between empty and full? - ((standard-e-stencil 1.0 1.0) radius thick fill layout props)) - (else ;If none of these, it is partially full. - (ly:stencil-add - ((rich-pe-stencil 1.0 1.0 0 360 identity) - radius - thick - (if (list-ref fill-list 4) - (expt (assoc-get 'F HOLE-FILL-LIST) 2) - 1) - layout - props) - ((rich-pe-stencil - 1.0 - 1.0 - (degree-first-true fill-list #t #t) - (degree-first-true fill-list #f #t) - identity) - radius - thick - (if - (true-entry? - (list-head fill-list (position-true-endpoint fill-list #t))) - (expt (assoc-get 'F HOLE-FILL-LIST) 2) - (assoc-get 'F HOLE-FILL-LIST)) - layout - props) - (if - (= 2 (n-true-entries (list-tail fill-list 1))) ; trill? - ((rich-pe-stencil - 1.0 - 1.0 - (degree-first-true fill-list #t #f) - (degree-first-true fill-list #f #f) - identity) - radius - thick - (assoc-get 'F HOLE-FILL-LIST) - layout - props) - empty-stencil)))))) + ((and + (list-ref fill-list 0) + (not (true-entry? (list-tail fill-list 1)))) ; is it empty? + ((standard-e-stencil 1.0 1.0) radius thick fill layout props)) + ((and + (list-ref fill-list 4) + (not (true-entry? (list-head fill-list 4)))) ; is it full? + ((standard-e-stencil 1.0 1.0) radius thick fill layout props)) + ((and + (list-ref fill-list 0) + (list-ref fill-list 4)) ; is it a trill between empty and full? + ((standard-e-stencil 1.0 1.0) radius thick fill layout props)) + (else ;If none of these, it is partially full. + (ly:stencil-add + ((rich-pe-stencil 1.0 1.0 0 360 identity) + radius + thick + (if (list-ref fill-list 4) + (expt (assoc-get 'F HOLE-FILL-LIST) 2) + 1) + layout + props) + ((rich-pe-stencil + 1.0 + 1.0 + (degree-first-true fill-list #t #t) + (degree-first-true fill-list #f #t) + identity) + radius + thick + (if + (true-entry? + (list-head fill-list (position-true-endpoint fill-list #t))) + (expt (assoc-get 'F HOLE-FILL-LIST) 2) + (assoc-get 'F HOLE-FILL-LIST)) + layout + props) + (if + (= 2 (n-true-entries (list-tail fill-list 1))) ; trill? + ((rich-pe-stencil + 1.0 + 1.0 + (degree-first-true fill-list #t #f) + (degree-first-true fill-list #f #f) + identity) + radius + thick + (assoc-get 'F HOLE-FILL-LIST) + layout + props) + empty-stencil)))))) (define (variable-column-circle-stencil scaler) (lambda (radius thick fill layout props) @@ -515,62 +515,62 @@ returns @samp{1/3}." ;; A stencil for ring-column circles that combines two of the above (define (ring-column-circle-stencil radius thick fill layout props) (if (= 0 (remainder fill (assoc-get 'R HOLE-FILL-LIST))) - (ly:stencil-add - ((if - (= fill (expt (assoc-get 'R HOLE-FILL-LIST) 2)) - gray-colorize - identity) + (ly:stencil-add + ((if + (= fill (expt (assoc-get 'R HOLE-FILL-LIST) 2)) + gray-colorize + identity) ((standard-e-stencil - (* (+ (- 1.0 (* 2 thick)) (/ thick 2))) - (* (+ (- 1.0 (* 2 thick)) (/ thick 2)))) - radius - (* (* 4 radius) thick) - 1 - layout - props)) - ((standard-e-stencil 1.0 1.0) radius thick 1 layout props) - (column-circle-stencil + (* (+ (- 1.0 (* 2 thick)) (/ thick 2))) + (* (+ (- 1.0 (* 2 thick)) (/ thick 2)))) + radius + (* (* 4 radius) thick) + 1 + layout + props)) + ((standard-e-stencil 1.0 1.0) radius thick 1 layout props) + (column-circle-stencil (+ (* (- 1.0 (* 4 thick)) radius) (/ thick 2)) thick (* - (if (= 0 (remainder fill (assoc-get 'F HOLE-FILL-LIST))) - (assoc-get 'F HOLE-FILL-LIST) - 1) - (if (= fill (expt (assoc-get 'R HOLE-FILL-LIST) 2)) - (/ fill (expt (assoc-get 'R HOLE-FILL-LIST) 2)) - (/ fill (assoc-get 'R HOLE-FILL-LIST)))) + (if (= 0 (remainder fill (assoc-get 'F HOLE-FILL-LIST))) + (assoc-get 'F HOLE-FILL-LIST) + 1) + (if (= fill (expt (assoc-get 'R HOLE-FILL-LIST) 2)) + (/ fill (expt (assoc-get 'R HOLE-FILL-LIST) 2)) + (/ fill (assoc-get 'R HOLE-FILL-LIST)))) layout props)) - (column-circle-stencil radius thick fill layout props))) + (column-circle-stencil radius thick fill layout props))) ;;; Flute family stencils (define flute-lh-b-key-stencil (standard-path-stencil - '((0 1.3) - (0 1.625 -0.125 1.75 -0.25 1.75) - (-0.55 1.75 -0.55 0.95 -0.25 0.7) - (0 0.4 0 0.125 0 0)) - 2 - 1.55)) + '((0 1.3) + (0 1.625 -0.125 1.75 -0.25 1.75) + (-0.55 1.75 -0.55 0.95 -0.25 0.7) + (0 0.4 0 0.125 0 0)) + 2 + 1.55)) (define flute-lh-bes-key-stencil (standard-path-stencil - '((0 1.3) - (0 1.625 -0.125 1.75 -0.25 1.75) - (-0.55 1.75 -0.55 0.95 -0.25 0.7) - (0 0.4 0 0.125 0 0)) - 2.0 - 1.3)) + '((0 1.3) + (0 1.625 -0.125 1.75 -0.25 1.75) + (-0.55 1.75 -0.55 0.95 -0.25 0.7) + (0 0.4 0 0.125 0 0)) + 2.0 + 1.3)) (define (flute-lh-gis-rh-bes-key-stencil deg) (rich-path-stencil - '((0.1 0.1 0.2 0.4 0.3 0.6) - (0.3 1.0 0.8 1.0 0.8 0.7) - (0.8 0.3 0.5 0.3 0 0)) - 1.0 - 1.0 - (lambda (stencil) (ly:stencil-rotate stencil deg 0 0)))) + '((0.1 0.1 0.2 0.4 0.3 0.6) + (0.3 1.0 0.8 1.0 0.8 0.7) + (0.8 0.3 0.5 0.3 0 0)) + 1.0 + 1.0 + (lambda (stencil) (ly:stencil-rotate stencil deg 0 0)))) (define flute-lh-gis-key-stencil (flute-lh-gis-rh-bes-key-stencil 0)) @@ -582,97 +582,97 @@ returns @samp{1/3}." (define flute-rh-ees-key-stencil (standard-path-stencil - '((0.8 0) (1.1 0 1.1 0.75 0.7 0.75) (0.5 0.75) (0.15 0.75 0.1 0.2 0 0)) - -2.38 - 1.4)) + '((0.8 0) (1.1 0 1.1 0.75 0.7 0.75) (0.5 0.75) (0.15 0.75 0.1 0.2 0 0)) + -2.38 + 1.4)) (define (piccolo-rh-x-key-stencil radius thick fill layout props) (interpret-markup - layout - props - (make-general-align-markup - Y - DOWN - (make-concat-markup - (make-name-keylist - `(,(text-fill-translate fill)) - '(("X" . #f)) - (* 9 radius)))))) + layout + props + (make-general-align-markup + Y + DOWN + (make-concat-markup + (make-name-keylist + `(,(text-fill-translate fill)) + '(("X" . #f)) + (* 9 radius)))))) (define flute-lower-row-stretch 1.4) (define flute-rh-cis-key-stencil (standard-path-stencil - '((0 0.75) (-0.8 0.75 -0.8 0 0 0)) - flute-lower-row-stretch - flute-lower-row-stretch)) + '((0 0.75) (-0.8 0.75 -0.8 0 0 0)) + flute-lower-row-stretch + flute-lower-row-stretch)) (define flute-rh-c-key-stencil (standard-path-stencil - '((0 0.75) (0.4 0.75) (0.4 0) (0 0)) - flute-lower-row-stretch - flute-lower-row-stretch)) + '((0 0.75) (0.4 0.75) (0.4 0) (0 0)) + flute-lower-row-stretch + flute-lower-row-stretch)) (define flute-rh-b-key-stencil (standard-path-stencil - '((0 0.75) (0.25 0.75) (0.25 0) (0 0)) - flute-lower-row-stretch - flute-lower-row-stretch)) + '((0 0.75) (0.25 0.75) (0.25 0) (0 0)) + flute-lower-row-stretch + flute-lower-row-stretch)) (define flute-rh-gz-key-stencil (rich-path-stencil - '((0.1 0.1 0.4 0.2 0.6 0.3) - (1.0 0.3 1.0 0.8 0.7 0.8) - (0.3 0.8 0.3 0.5 0 0)) - flute-lower-row-stretch - flute-lower-row-stretch - (lambda (stencil) (ly:stencil-rotate stencil 160 0 0)))) + '((0.1 0.1 0.4 0.2 0.6 0.3) + (1.0 0.3 1.0 0.8 0.7 0.8) + (0.3 0.8 0.3 0.5 0 0)) + flute-lower-row-stretch + flute-lower-row-stretch + (lambda (stencil) (ly:stencil-rotate stencil 160 0 0)))) ;;; Shared oboe/clarinet stencils (define (oboe-lh-gis-lh-low-b-key-stencil gis?) (let* - ((x 1.2) - (y 0.4) - (scaling-factor 1.7) - (up-part - (car + ((x 1.2) + (y 0.4) + (scaling-factor 1.7) + (up-part + (car (split-bezier - `((0.0 . 0.0) (0.0 . ,y) (,x . ,y) (,x . 0.0)) - 0.8))) - (down-part - (cdr + `((0.0 . 0.0) (0.0 . ,y) (,x . ,y) (,x . 0.0)) + 0.8))) + (down-part + (cdr (split-bezier - `((,x . 0.0) (,x . ,(- y)) (0.0 . ,(- y)) (0.0 . 0.0)) - 0.2)))) + `((,x . 0.0) (,x . ,(- y)) (0.0 . ,(- y)) (0.0 . 0.0)) + 0.2)))) (if gis? - (standard-path-stencil - (append + (standard-path-stencil + (append (append - `((0.25 ,(/ y -2) 0.75 ,(/ y -2) 1.0 0.0)) - (map (lambda (l) - (flatten-list - (map (lambda (x) - (coord-translate - (coord-rotate x (atan (/ y (* 2 0.25)))) - '(1.0 . 0))) - l))) - `(((0 . ,y) (,x . ,y) (,x . 0)) - ((,x . ,(- y)) (0 . ,(- y)) (0 . 0))))) + `((0.25 ,(/ y -2) 0.75 ,(/ y -2) 1.0 0.0)) + (map (lambda (l) + (flatten-list + (map (lambda (x) + (coord-translate + (coord-rotate x (atan (/ y (* 2 0.25)))) + '(1.0 . 0))) + l))) + `(((0 . ,y) (,x . ,y) (,x . 0)) + ((,x . ,(- y)) (0 . ,(- y)) (0 . 0))))) `((0.75 ,(/ y -2) 0.25 ,(/ y -2) 0.0 0.0))) - scaling-factor - scaling-factor) - (standard-path-stencil - (map (lambda (l) - (flatten-list + scaling-factor + scaling-factor) + (standard-path-stencil + (map (lambda (l) + (flatten-list (map (lambda (x) (coord-rotate x (atan (/ y (* 2 0.25))))) l))) - `(,(list-tail up-part 1) - ,(list-head down-part 1) - ,(list-tail down-part 1))) - (- scaling-factor) - (- scaling-factor))))) + `(,(list-tail up-part 1) + ,(list-head down-part 1) + ,(list-tail down-part 1))) + (- scaling-factor) + (- scaling-factor))))) (define oboe-lh-gis-key-stencil (oboe-lh-gis-lh-low-b-key-stencil #t)) @@ -680,13 +680,13 @@ returns @samp{1/3}." (define (oboe-lh-ees-lh-bes-key-stencil ees?) (standard-path-stencil - `((0 1.5) - (0 1.625 -0.125 1.75 -0.25 1.75) - (-0.5 1.75 -0.5 0.816 -0.25 0.5) - (0 0.25 0 0.125 0 0) - (0 ,(if ees? -0.6 -0.3))) - (* (if ees? -1.0 1.0) -1.8) - 1.8)) + `((0 1.5) + (0 1.625 -0.125 1.75 -0.25 1.75) + (-0.5 1.75 -0.5 0.816 -0.25 0.5) + (0 0.25 0 0.125 0 0) + (0 ,(if ees? -0.6 -0.3))) + (* (if ees? -1.0 1.0) -1.8) + 1.8)) (define oboe-lh-ees-key-stencil (oboe-lh-ees-lh-bes-key-stencil #t)) @@ -697,13 +697,13 @@ returns @samp{1/3}." (define (oboe-lh-octave-key-stencil long?) (let* ((h (if long? 1.4 1.2))) (standard-path-stencil - `((-0.4 0 -0.4 1.0 -0.1 1.0) - (-0.1 ,h) - (0.1 ,h) - (0.1 1.0) - (0.4 1.0 0.4 0 0 0)) - 2.0 - 2.0))) + `((-0.4 0 -0.4 1.0 -0.1 1.0) + (-0.1 ,h) + (0.1 ,h) + (0.1 1.0) + (0.4 1.0 0.4 0 0 0)) + 2.0 + 2.0))) (define oboe-lh-I-key-stencil (oboe-lh-octave-key-stencil #f)) @@ -729,13 +729,13 @@ returns @samp{1/3}." (define (oboe-rh-c-rh-ees-key-stencil c?) (rich-path-stencil - '((1.0 0.0 1.0 0.70 1.5 0.70) - (2.25 0.70 2.25 -0.4 1.5 -0.4) - (1.0 -0.4 1.0 0 0 0) - (-0.15 0)) - 2.0 - 1.4 - (lambda (stencil) (ly:stencil-rotate stencil (if c? 170 180) 0 0)))) + '((1.0 0.0 1.0 0.70 1.5 0.70) + (2.25 0.70 2.25 -0.4 1.5 -0.4) + (1.0 -0.4 1.0 0 0 0) + (-0.15 0)) + 2.0 + 1.4 + (lambda (stencil) (ly:stencil-rotate stencil (if c? 170 180) 0 0)))) (define oboe-rh-banana-key-stencil oboe-rh-gis-key-stencil) @@ -743,12 +743,12 @@ returns @samp{1/3}." (define oboe-rh-cis-key-stencil (rich-path-stencil - '((0.6 0.0 0.6 0.50 1.25 0.50) - (2.25 0.50 2.25 -0.4 1.25 -0.4) - (0.6 -0.4 0.6 0 0 0)) - -0.9 - 1.0 - (lambda (stencil) (ly:stencil-rotate stencil 0 0 0)))) + '((0.6 0.0 0.6 0.50 1.25 0.50) + (2.25 0.50 2.25 -0.4 1.25 -0.4) + (0.6 -0.4 0.6 0 0 0)) + -0.9 + 1.0 + (lambda (stencil) (ly:stencil-rotate stencil 0 0 0)))) (define oboe-rh-ees-key-stencil (oboe-rh-c-rh-ees-key-stencil #f)) @@ -759,22 +759,22 @@ returns @samp{1/3}." (define clarinet-lh-R-key-stencil (let* ((halfbase (cos (/ PI 10))) - (height (* - halfbase - (/ (sin (/ (* 4 PI) 10)) (cos (/ (* 4 PI) 10)))))) - (standard-path-stencil - `( - (0 ,(/ -4.0 3.0) -2.0 ,(/ -4.0 3.0) -2.0 0.0) - (-1.5 ,(* 0.5 height) -1.25 ,(* 0.75 height) -1.0 ,height) - (-0.75 ,(* 0.75 height) -0.5 ,(* 0.5 height) 0.0 0.0)) - 0.9 - 0.9))) + (height (* + halfbase + (/ (sin (/ (* 4 PI) 10)) (cos (/ (* 4 PI) 10)))))) + (standard-path-stencil + `( + (0 ,(/ -4.0 3.0) -2.0 ,(/ -4.0 3.0) -2.0 0.0) + (-1.5 ,(* 0.5 height) -1.25 ,(* 0.75 height) -1.0 ,height) + (-0.75 ,(* 0.75 height) -0.5 ,(* 0.5 height) 0.0 0.0)) + 0.9 + 0.9))) (define (clarinet-lh-a-key-stencil radius thick fill layout props) (let* ((width 0.4) (height 0.75) (linelen 0.45)) - (ly:stencil-add - ((standard-e-stencil width height) radius thick fill layout props) - (ly:stencil-translate + (ly:stencil-add + ((standard-e-stencil width height) radius thick fill layout props) + (ly:stencil-translate (make-line-stencil thick 0 0 0 (* linelen radius)) (cons 0 (* height radius)))))) @@ -794,30 +794,30 @@ returns @samp{1/3}." (define clarinet-rh-low-c-key-stencil (standard-path-stencil - '((0.0 1.5) - (0.0 2.5 -1.0 2.5 -1.0 0.75) - (-1.0 0.1 0.0 0.25 0.0 0.3) - (0.0 0.0)) - 0.8 - 0.8)) + '((0.0 1.5) + (0.0 2.5 -1.0 2.5 -1.0 0.75) + (-1.0 0.1 0.0 0.25 0.0 0.3) + (0.0 0.0)) + 0.8 + 0.8)) (define clarinet-rh-low-cis-key-stencil (standard-path-stencil - '((0.0 1.17) - (0.0 1.67 -1.0 1.67 -1.0 0.92) - (-1.0 0.47 0.0 0.52 0.0 0.62) - (0.0 0.0)) - 0.8 - 0.8)) + '((0.0 1.17) + (0.0 1.67 -1.0 1.67 -1.0 0.92) + (-1.0 0.47 0.0 0.52 0.0 0.62) + (0.0 0.0)) + 0.8 + 0.8)) (define clarinet-rh-low-d-key-stencil (standard-path-stencil - '((0.0 1.05) - (0.0 1.55 -1.0 1.55 -1.0 0.8) - (-1.0 0.35 0.0 0.4 0.0 0.5) - (0.0 0.0)) - 0.8 - 0.8)) + '((0.0 1.05) + (0.0 1.55 -1.0 1.55 -1.0 0.8) + (-1.0 0.35 0.0 0.4 0.0 0.5) + (0.0 0.0)) + 0.8 + 0.8)) (define clarinet-rh-one-key-stencil (standard-e-stencil 0.5 0.25)) @@ -841,52 +841,52 @@ returns @samp{1/3}." (define clarinet-rh-fis-key-stencil (standard-path-stencil - `(,(bezier-head-for-stencil - '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0)) - 0.5) - ,(bezier-head-for-stencil - '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75)) - 0.5) - (1.0 1.0 0.0 1.0 0.0 0.0)) - CL-RH-H-STRETCH - CL-RH-V-STRETCH)) + `(,(bezier-head-for-stencil + '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0)) + 0.5) + ,(bezier-head-for-stencil + '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75)) + 0.5) + (1.0 1.0 0.0 1.0 0.0 0.0)) + CL-RH-H-STRETCH + CL-RH-V-STRETCH)) (define clarinet-rh-gis-key-stencil (standard-path-stencil - '((0.0 1.0 1.0 1.0 1.0 0.0) (1.0 -1.0 0.0 -1.0 0.0 0.0)) - CL-RH-H-STRETCH - CL-RH-V-STRETCH)) + '((0.0 1.0 1.0 1.0 1.0 0.0) (1.0 -1.0 0.0 -1.0 0.0 0.0)) + CL-RH-H-STRETCH + CL-RH-V-STRETCH)) (define clarinet-rh-e-key-stencil (standard-path-stencil - `(,(bezier-head-for-stencil - '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0)) - 0.5) - ,(bezier-head-for-stencil - '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75)) - 0.5) - ,(bezier-head-for-stencil - `((1.0 . 0.0) (,(/ 1 3) . 0.0) (,(/ 1 3) . 1.5) (1.0 . 1.5)) - 0.5) - ,(bezier-head-for-stencil - `((0.5 . 0.75) (,(/ -1 6) . 0.75) (,(/ -1 6) . -0.75) (0.5 . -0.75)) - 0.5)) - CL-RH-H-STRETCH - CL-RH-V-STRETCH)) + `(,(bezier-head-for-stencil + '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0)) + 0.5) + ,(bezier-head-for-stencil + '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75)) + 0.5) + ,(bezier-head-for-stencil + `((1.0 . 0.0) (,(/ 1 3) . 0.0) (,(/ 1 3) . 1.5) (1.0 . 1.5)) + 0.5) + ,(bezier-head-for-stencil + `((0.5 . 0.75) (,(/ -1 6) . 0.75) (,(/ -1 6) . -0.75) (0.5 . -0.75)) + 0.5)) + CL-RH-H-STRETCH + CL-RH-V-STRETCH)) (define clarinet-rh-f-key-stencil clarinet-rh-gis-key-stencil) (define bass-clarinet-rh-ees-key-stencil (standard-path-stencil - `(,(bezier-head-for-stencil - '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0)) - 0.5) - ,(bezier-head-for-stencil - '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75)) - 0.5) - (1.0 1.0 0.0 1.0 0.0 0.0)) - CL-RH-H-STRETCH - (- CL-RH-V-STRETCH))) + `(,(bezier-head-for-stencil + '((0.0 . 0.0) (0.0 . -1.0) (1.0 . -1.0) (1.0 . 0.0)) + 0.5) + ,(bezier-head-for-stencil + '((0.5 . -0.75) (0.5 . 0.25) (1.5 . 0.25) (1.5 . -0.75)) + 0.5) + (1.0 1.0 0.0 1.0 0.0 0.0)) + CL-RH-H-STRETCH + (- CL-RH-V-STRETCH))) (define low-bass-clarinet-rh-ees-key-stencil clarinet-rh-e-key-stencil) @@ -908,21 +908,21 @@ returns @samp{1/3}." (define saxophone-lh-gis-key-stencil (standard-path-stencil - '((0.0 0.4) - (0.0 0.8 3.0 0.8 3.0 0.4) - (3.0 0.0) - (3.0 -0.4 0.0 -0.4 0.0 0.0)) - 0.8 - 0.8)) + '((0.0 0.4) + (0.0 0.8 3.0 0.8 3.0 0.4) + (3.0 0.0) + (3.0 -0.4 0.0 -0.4 0.0 0.0)) + 0.8 + 0.8)) (define (saxophone-lh-b-cis-key-stencil flip?) (standard-path-stencil - '((0.0 1.0) - (0.4 1.0 0.8 0.9 1.35 0.8) - (1.35 0.0) - (0.0 0.0)) - (* (if flip? -1 1) 0.8) - 0.8)) + '((0.0 1.0) + (0.4 1.0 0.8 0.9 1.35 0.8) + (1.35 0.0) + (0.0 0.0)) + (* (if flip? -1 1) 0.8) + 0.8)) (define saxophone-lh-cis-key-stencil (saxophone-lh-b-cis-key-stencil #t)) @@ -930,27 +930,27 @@ returns @samp{1/3}." (define saxophone-lh-low-bes-key-stencil (standard-path-stencil - '((3.0 0.0) (3.0 -1.5 0.0 -1.5 0.0 0.0)) - 0.8 - 0.8)) + '((3.0 0.0) (3.0 -1.5 0.0 -1.5 0.0 0.0)) + 0.8 + 0.8)) (define (saxophone-rh-side-key-stencil width height) (standard-path-stencil - `((0.0 ,height) - (0.05 ,(+ height 0.05) 0.1 ,(+ height 0.1) 0.15 ,(+ height 0.15)) - (,(- width 0.15) ,(+ height 0.15)) - (,(- width 0.1) - ,(+ height 0.1) - ,(- width 0.05) - ,(+ height 0.05) - ,width - ,height) - (,width 0.0) - (,(- width 0.05) -0.05 ,(- width 0.1) -0.1 ,(- width 0.15) -0.15) - (0.15 -0.15) - (0.1 -0.1 0.05 -0.05 0.0 0.0)) - 1.0 - 1.0)) + `((0.0 ,height) + (0.05 ,(+ height 0.05) 0.1 ,(+ height 0.1) 0.15 ,(+ height 0.15)) + (,(- width 0.15) ,(+ height 0.15)) + (,(- width 0.1) + ,(+ height 0.1) + ,(- width 0.05) + ,(+ height 0.05) + ,width + ,height) + (,width 0.0) + (,(- width 0.05) -0.05 ,(- width 0.1) -0.1 ,(- width 0.15) -0.15) + (0.15 -0.15) + (0.1 -0.1 0.05 -0.05 0.0 0.0)) + 1.0 + 1.0)) (define saxophone-rh-e-key-stencil (saxophone-rh-side-key-stencil 0.9 1.2)) @@ -960,18 +960,18 @@ returns @samp{1/3}." (define saxophone-rh-high-fis-key-stencil (standard-path-stencil - (append - '((0.0 1.0) (0.0 1.4 0.6 1.4 0.6 1.0) (0.6 0.0)) - (map (lambda (l) - (flatten-list - (map (lambda (x) - (coord-rotate x (atan (* -1 (/ PI 6))))) - l))) - '(((0.6 . -1.0)) - ((0.6 . -1.4) (0.0 . -1.4) (0.0 . -1.0)) - ((0.0 . 0.0))))) - 0.75 - 0.75)) + (append + '((0.0 1.0) (0.0 1.4 0.6 1.4 0.6 1.0) (0.6 0.0)) + (map (lambda (l) + (flatten-list + (map (lambda (x) + (coord-rotate x (atan (* -1 (/ PI 6))))) + l))) + '(((0.6 . -1.0)) + ((0.6 . -1.4) (0.0 . -1.4) (0.0 . -1.0)) + ((0.0 . 0.0))))) + 0.75 + 0.75)) (define saxophone-rh-fis-key-stencil (standard-e-stencil 1.0 0.5)) @@ -979,112 +979,112 @@ returns @samp{1/3}." (define saxophone-rh-low-c-key-stencil (standard-path-stencil - '((3.0 0.0) (3.0 -1.5 0.0 -1.5 0.0 0.0)) - 0.8 - 0.8)) + '((3.0 0.0) (3.0 -1.5 0.0 -1.5 0.0 0.0)) + 0.8 + 0.8)) (define (saxophone-lh-low-a-key-stencil radius thick fill layout props) (interpret-markup - layout - props - (make-general-align-markup - Y - DOWN - (make-concat-markup - (make-name-keylist - `(,(text-fill-translate fill)) - '(("lowA" . #f)) - (* 9 radius)))))) + layout + props + (make-general-align-markup + Y + DOWN + (make-concat-markup + (make-name-keylist + `(,(text-fill-translate fill)) + '(("lowA" . #f)) + (* 9 radius)))))) ;;; Bassoon family stencils (define (bassoon-bend-info-maker height gap cut) (let* ( - (first-bezier - (flatten-list - (car - (split-bezier - `((0.0 . ,(+ height gap)) - (0.0 . ,(+ height (+ gap 1.0))) - (1.0 . ,(+ height (+ gap 2.0))) - (2.0 . ,(+ height (+ gap 2.0)))) - cut)))) - (second-bezier - (flatten-list - (reverse - (car + (first-bezier + (flatten-list + (car (split-bezier + `((0.0 . ,(+ height gap)) + (0.0 . ,(+ height (+ gap 1.0))) + (1.0 . ,(+ height (+ gap 2.0))) + (2.0 . ,(+ height (+ gap 2.0)))) + cut)))) + (second-bezier + (flatten-list + (reverse + (car + (split-bezier `((1.0 . ,height) - (1.0 . ,(+ 0.5 height)) - (1.5 . ,(+ 1.0 height)) - (2.0 . ,(+ 1.0 height))) + (1.0 . ,(+ 0.5 height)) + (1.5 . ,(+ 1.0 height)) + (2.0 . ,(+ 1.0 height))) cut))))) - (slope-offset1 - (get-slope-offset - `(,(list-ref first-bezier 4) . ,(list-ref first-bezier 5)) - `(,(list-ref first-bezier 6) . ,(list-ref first-bezier 7)))) - (slope-offset2 - (get-slope-offset - `(,(list-ref second-bezier 0) . ,(list-ref second-bezier 1)) - `(,(list-ref second-bezier 2) . ,(list-ref second-bezier 3))))) - (list first-bezier second-bezier slope-offset1 slope-offset2))) + (slope-offset1 + (get-slope-offset + `(,(list-ref first-bezier 4) . ,(list-ref first-bezier 5)) + `(,(list-ref first-bezier 6) . ,(list-ref first-bezier 7)))) + (slope-offset2 + (get-slope-offset + `(,(list-ref second-bezier 0) . ,(list-ref second-bezier 1)) + `(,(list-ref second-bezier 2) . ,(list-ref second-bezier 3))))) + (list first-bezier second-bezier slope-offset1 slope-offset2))) (define (make-tilted-portion - first-bezier - second-bezier - slope-offset1 - slope-offset2 - keylen - bezier?) + first-bezier + second-bezier + slope-offset1 + slope-offset2 + keylen + bezier?) (append - `((,(+ keylen (list-ref first-bezier 6)) - ,(+ + `((,(+ keylen (list-ref first-bezier 6)) + ,(+ (* + (car slope-offset1) + (+ keylen (list-ref first-bezier 6))) (cdr slope-offset1)))) + ((if bezier? (lambda (x) `(,(apply append x))) identity) + `((,(+ (+ keylen 1.75) (list-ref first-bezier 6)) + ,(+ + (* (car slope-offset1) - (+ keylen (list-ref first-bezier 6))) (cdr slope-offset1)))) - ((if bezier? (lambda (x) `(,(apply append x))) identity) - `((,(+ (+ keylen 1.75) (list-ref first-bezier 6)) + (+ (+ keylen 1.75) (list-ref first-bezier 6))) + (cdr slope-offset1))) + (,(+ (+ keylen 1.75) (list-ref second-bezier 0)) ,(+ - (* - (car slope-offset1) - (+ (+ keylen 1.75) (list-ref first-bezier 6))) - (cdr slope-offset1))) - (,(+ (+ keylen 1.75) (list-ref second-bezier 0)) + (* + (car slope-offset2) + (+ (+ keylen 1.75) (list-ref second-bezier 0))) + (cdr slope-offset2))) + (,(+ keylen (list-ref second-bezier 0)) ,(+ - (* - (car slope-offset2) - (+ (+ keylen 1.75) (list-ref second-bezier 0))) - (cdr slope-offset2))) - (,(+ keylen (list-ref second-bezier 0)) - ,(+ - (* (car slope-offset2) (+ keylen (list-ref second-bezier 0))) - (cdr slope-offset2))))) - `(,(list-head second-bezier 2)))) + (* (car slope-offset2) (+ keylen (list-ref second-bezier 0))) + (cdr slope-offset2))))) + `(,(list-head second-bezier 2)))) (define (rich-bassoon-uber-key-stencil height gap cut keylen d1 d2 proc bezier?) (let* ((info-list (bassoon-bend-info-maker height gap cut)) - (first-bezier (car info-list)) - (second-bezier (cadr info-list)) - (slope-offset1 (caddr info-list)) - (slope-offset2 (cadddr info-list))) - (rich-path-stencil - (append + (first-bezier (car info-list)) + (second-bezier (cadr info-list)) + (slope-offset1 (caddr info-list)) + (slope-offset2 (cadddr info-list))) + (rich-path-stencil + (append `((0.0 ,(+ height gap)) - ,(list-tail first-bezier 2)) + ,(list-tail first-bezier 2)) (make-tilted-portion - first-bezier - second-bezier - slope-offset1 - slope-offset2 - keylen - bezier?) + first-bezier + second-bezier + slope-offset1 + slope-offset2 + keylen + bezier?) `(,(list-tail second-bezier 2) - (1.0 0.0) - (0.0 0.0))) - d1 - d2 - proc))) + (1.0 0.0) + (0.0 0.0))) + d1 + d2 + proc))) (define (bassoon-uber-key-stencil height gap cut keylen d1 d2) (rich-bassoon-uber-key-stencil height gap cut keylen d1 d2 identity #t)) @@ -1097,15 +1097,15 @@ returns @samp{1/3}." (define bassoon-lh-ees-key-stencil (rich-e-stencil - 1.2 - 0.6 + 1.2 + 0.6 (lambda (stencil) (ly:stencil-rotate stencil 30 0 0)))) (define bassoon-lh-cis-key-stencil (rich-e-stencil - 1.0 - 0.5 - (lambda (stencil) (ly:stencil-rotate stencil 30 0 0)))) + 1.0 + 0.5 + (lambda (stencil) (ly:stencil-rotate stencil 30 0 0)))) (define bassoon-lh-lbes-key-stencil (bassoon-uber-key-stencil 1.0 0.5 0.7 0.5 0.6 -0.6)) @@ -1118,40 +1118,40 @@ returns @samp{1/3}." (define bassoon-lh-ld-key-stencil (standard-path-stencil - '((-0.8 4.0 1.4 4.0 0.6 0.0) - (0.5 -0.5 0.5 -0.8 0.6 -1.0) - (0.7 -1.2 0.8 -1.3 0.8 -1.8) - (0.5 -1.8) - (0.5 -1.4 0.4 -1.2 0.3 -1.1) - (0.2 -1.0 0.1 -0.5 0.0 0.0)) - 1.0 - 1.0)) + '((-0.8 4.0 1.4 4.0 0.6 0.0) + (0.5 -0.5 0.5 -0.8 0.6 -1.0) + (0.7 -1.2 0.8 -1.3 0.8 -1.8) + (0.5 -1.8) + (0.5 -1.4 0.4 -1.2 0.3 -1.1) + (0.2 -1.0 0.1 -0.5 0.0 0.0)) + 1.0 + 1.0)) (define bassoon-lh-d-flick-key-stencil (let ((height 3.0)) (standard-path-stencil - `((0.0 ,height) + `((0.0 ,height) (0.2 ,(+ height 1.6) 0.8 ,(+ height 1.8) 1.0 ,(+ height 1.8)) (1.4 ,(+ height 1.8) 1.9 ,(+ height 1.3) 1.9 ,(+ height 1.0)) (1.9 ,(+ height 0.7) 1.0 ,(+ height 0.4) 0.8 ,(+ height 0.3)) (0.6 ,(+ height 0.2) 0.4 ,(+ height 0.1) 0.4 ,(- height 0.1)) (0.4 0.0) (0.0 0.0)) - -1.0 - -1.0))) + -1.0 + -1.0))) (define bassoon-lh-c-flick-key-stencil (let ((height 3.0)) (standard-path-stencil - `((0.0 ,height) - (0.0 ,(+ height 1.6) 0.4 ,(+ height 1.8) 0.5 ,(+ height 1.8)) - (0.7 ,(+ height 1.8) 0.9 ,(+ height 1.3) 0.9 ,(+ height 1.0)) - (0.9 ,(+ height 0.5) 0.7 ,(+ height 0.4) 0.6 ,(+ height 0.3)) - (0.5 ,(+ height 0.2) 0.4 ,(+ height 0.1) 0.4 ,(- height 0.1)) - (0.4 0.0) - (0.0 0.0)) - -1.0 - -1.0))) + `((0.0 ,height) + (0.0 ,(+ height 1.6) 0.4 ,(+ height 1.8) 0.5 ,(+ height 1.8)) + (0.7 ,(+ height 1.8) 0.9 ,(+ height 1.3) 0.9 ,(+ height 1.0)) + (0.9 ,(+ height 0.5) 0.7 ,(+ height 0.4) 0.6 ,(+ height 0.3)) + (0.5 ,(+ height 0.2) 0.4 ,(+ height 0.1) 0.4 ,(- height 0.1)) + (0.4 0.0) + (0.0 0.0)) + -1.0 + -1.0))) (define bassoon-lh-a-flick-key-stencil (bassoon-uber-key-stencil 5.0 1.0 0.3 0.6 -0.5 -0.5)) @@ -1163,14 +1163,14 @@ returns @samp{1/3}." (define bassoon-rh-cis-key-stencil (rich-bassoon-uber-key-stencil - 1.1 - 1.5 - 0.9 - 0.3 - 0.5 - 0.5 - (lambda (stencil) (ly:stencil-rotate stencil -76 0 0)) - #t)) + 1.1 + 1.5 + 0.9 + 0.3 + 0.5 + 0.5 + (lambda (stencil) (ly:stencil-rotate stencil -76 0 0)) + #t)) (define bassoon-rh-bes-key-stencil little-elliptical-key-stencil) @@ -1179,29 +1179,29 @@ returns @samp{1/3}." (define bassoon-rh-f-key-stencil (let* ((height 0.5) (gap 1.0) (cut 0.8) (keylen 1.5) - (info-list (bassoon-bend-info-maker height gap cut)) - (first-bezier (car info-list)) - (second-bezier (cadr info-list)) - (slope-offset1 (caddr info-list)) - (slope-offset2 (cadddr info-list))) - (standard-path-stencil - (append + (info-list (bassoon-bend-info-maker height gap cut)) + (first-bezier (car info-list)) + (second-bezier (cadr info-list)) + (slope-offset1 (caddr info-list)) + (slope-offset2 (cadddr info-list))) + (standard-path-stencil + (append (map - (lambda (l) - (rotunda-map - - - l - (list-tail first-bezier 6))) - (make-tilted-portion - first-bezier - second-bezier - slope-offset1 - slope-offset2 - keylen - #t)) + (lambda (l) + (rotunda-map + - + l + (list-tail first-bezier 6))) + (make-tilted-portion + first-bezier + second-bezier + slope-offset1 + slope-offset2 + keylen + #t)) '((0.0 0.0))) - -0.7 - 0.7))) + -0.7 + 0.7))) (define bassoon-rh-gis-key-stencil (bassoon-uber-key-stencil 0.3 1.0 0.8 1.0 -0.7 0.7)) diff --git a/scm/display-lily.scm b/scm/display-lily.scm index 788f89e359..7c1ec41925 100644 --- a/scm/display-lily.scm +++ b/scm/display-lily.scm @@ -40,18 +40,18 @@ "Define a display method for a music type and store it in the `display-methods' property of the music type entry found in the `music-name-to-property-table' hash table. Print methods previously -defined for that music type are lost. +defined for that music type are lost. Syntax: (define-display-method MusicType (expression parser) - ...body...))" + ...body...))" `(let ((type-props (hashq-ref music-name-to-property-table - ',music-type '())) - (method (lambda ,vars - ,@body))) + ',music-type '())) + (method (lambda ,vars + ,@body))) (set! type-props - (assoc-set! type-props 'display-methods (list method))) + (assoc-set! type-props 'display-methods (list method))) (hashq-set! music-name-to-property-table - ',music-type - type-props) + ',music-type + type-props) method)) (define-macro (define-extra-display-method music-type vars . body) @@ -60,24 +60,24 @@ is supposed to have been previously defined with `define-display-method'. This new method should return a string or #f. If #f is returned, the next display method will be called." `(let* ((type-props (hashq-ref music-name-to-property-table - ',music-type '())) - (methods (assoc-ref type-props 'display-methods)) - (new-method (lambda ,vars - ,@body))) + ',music-type '())) + (methods (assoc-ref type-props 'display-methods)) + (new-method (lambda ,vars + ,@body))) (set! type-props - (assoc-set! type-props - 'display-methods - (cons new-method methods))) + (assoc-set! type-props + 'display-methods + (cons new-method methods))) (hashq-set! music-name-to-property-table - ',music-type - type-props) + ',music-type + type-props) new-method)) (define* (tag->lily-string expr #:optional (post-event? #f)) (format #f "~{~a ~}" - (map (lambda (tag) - (format #f "~a\\tag #'~a" (if post-event? "-" "") tag)) - (ly:music-property expr 'tags)))) + (map (lambda (tag) + (format #f "~a\\tag #'~a" (if post-event? "-" "") tag)) + (ly:music-property expr 'tags)))) (define* (tweaks->lily-string expr #:optional (post-event? #f)) (format #f "~{~a ~}" @@ -103,25 +103,25 @@ display method will be called." "Print @var{expr}, a music expression, in LilyPond syntax." (if (ly:music? expr) (let* ((music-type (ly:music-property expr 'name)) - (procs (assoc-ref (hashq-ref music-name-to-property-table - music-type '()) - 'display-methods)) - (result-string (and procs (any (lambda (proc) - (proc expr parser)) - procs)))) - (if result-string - (format #f "~a~a~a" + (procs (assoc-ref (hashq-ref music-name-to-property-table + music-type '()) + 'display-methods)) + (result-string (and procs (any (lambda (proc) + (proc expr parser)) + procs)))) + (if result-string + (format #f "~a~a~a" (tag->lily-string expr (post-event? expr)) (tweaks->lily-string expr (post-event? expr)) - result-string) - (format #f "%{ Print method not implemented for music type ~a %}" - music-type))) + result-string) + (format #f "%{ Print method not implemented for music type ~a %}" + music-type))) (format #f "%{ expecting a music expression: ~a %}" expr))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Music pattern matching -;;; +;;; (define (var? x) (and (symbol? x) (char=? #\? (string-ref (symbol->string x) 0)))) @@ -136,16 +136,16 @@ display method will be called." (define (music-or-var-list? x) (and (pair? x) (every (lambda (e) - (or (music? e) (var? e))) - x))) + (or (music? e) (var? e))) + x))) (define (key-val-list->alist lst) (define (key-val-list->alist-aux lst prev-result) (if (null? lst) - prev-result - (key-val-list->alist-aux (cddr lst) - (cons (cons (first lst) (second lst)) - prev-result)))) + prev-result + (key-val-list->alist-aux (cddr lst) + (cons (cons (first lst) (second lst)) + prev-result)))) (reverse! (key-val-list->alist-aux lst (list)))) (define (gen-condition expr pattern) @@ -153,100 +153,100 @@ display method will be called." Generate an form that checks if the properties of `expr' match thoses described in `pattern'." (let* (;; all (property . value) found at the first depth in pattern, - ;; including a (name . <Musictype>) pair. - (pat-all-props (cons (cons 'name (second pattern)) - (key-val-list->alist (cddr pattern)))) - ;; all (property . value) pairs found in pattern, where value is not - ;; a ?var, a music expression or a music list. - (prop-vals (remove (lambda (kons) - (or (var? (cdr kons)) - (music? (cdr kons)) - (music-or-var-list? (cdr kons)))) - pat-all-props)) - ;; list of (property . element) pairs, where element is a music expression - (element-list (filter (lambda (kons) (music? (cdr kons))) - pat-all-props)) - ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a - ;; list a music expressions - (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons))) - pat-all-props))) - `(and + ;; including a (name . <Musictype>) pair. + (pat-all-props (cons (cons 'name (second pattern)) + (key-val-list->alist (cddr pattern)))) + ;; all (property . value) pairs found in pattern, where value is not + ;; a ?var, a music expression or a music list. + (prop-vals (remove (lambda (kons) + (or (var? (cdr kons)) + (music? (cdr kons)) + (music-or-var-list? (cdr kons)))) + pat-all-props)) + ;; list of (property . element) pairs, where element is a music expression + (element-list (filter (lambda (kons) (music? (cdr kons))) + pat-all-props)) + ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a + ;; list a music expressions + (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons))) + pat-all-props))) + `(and ;; a form that checks that `expr' is a music expression ;; before actually accessing its properties... (ly:music? ,expr) ;; a form that checks that `expr' properties have the same ;; values as those given in `pattern' ,@(map (lambda (prop-val) - (let ((prop (car prop-val)) - (val (cdr prop-val))) - `(and (not (null? (ly:music-property ,expr ',prop))) - (equal? (ly:music-property ,expr ',prop) ,val)))) - prop-vals) + (let ((prop (car prop-val)) + (val (cdr prop-val))) + `(and (not (null? (ly:music-property ,expr ',prop))) + (equal? (ly:music-property ,expr ',prop) ,val)))) + prop-vals) ;; build the test condition for each element found in a (property . element) pair. ;; (typically, property will be 'element) ,@(map (lambda (prop-element) - (gen-condition `(ly:music-property ,expr ',(car prop-element)) (cdr prop-element))) - element-list) + (gen-condition `(ly:music-property ,expr ',(car prop-element)) (cdr prop-element))) + element-list) ;; build the test conditions for each element found in a (property . (e1 e2 ...)) pair. ;; this requires accessing to an element of a list, hence the index. ;; (typically, property will be 'elements) ,@(map (lambda (prop-elements) - (let ((ges (gensym)) - (index -1)) - `(and ,@(map (lambda (e) - (set! index (1+ index)) - (if (music? e) - (gen-condition `(and (> (length (ly:music-property ,expr ',(car prop-elements))) - ,index) - (list-ref (ly:music-property ,expr ',(car prop-elements)) - ,index)) - e) - #t)) - (cdr prop-elements))))) - elements-list)))) + (let ((ges (gensym)) + (index -1)) + `(and ,@(map (lambda (e) + (set! index (1+ index)) + (if (music? e) + (gen-condition `(and (> (length (ly:music-property ,expr ',(car prop-elements))) + ,index) + (list-ref (ly:music-property ,expr ',(car prop-elements)) + ,index)) + e) + #t)) + (cdr prop-elements))))) + elements-list)))) (define (gen-bindings expr pattern) "Helper function for `with-music-match'. Generate binding forms by looking for ?var symbol in pattern." (let* (;; all (property . value) found at the first depth of pattern, - ;; including a (name . <Musictype>) pair. - (pat-all-props (cons (cons 'name (second pattern)) - (key-val-list->alist (cddr pattern)))) - ;; all (property . ?var) pairs - (prop-vars (filter (lambda (kons) (var? (cdr kons))) - pat-all-props)) - ;; list of (property . element) pairs, where element is a music expression - (element-list (filter (lambda (kons) (music? (cdr kons))) - pat-all-props)) - ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a - ;; list a music expressions - (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons))) - pat-all-props))) - (append + ;; including a (name . <Musictype>) pair. + (pat-all-props (cons (cons 'name (second pattern)) + (key-val-list->alist (cddr pattern)))) + ;; all (property . ?var) pairs + (prop-vars (filter (lambda (kons) (var? (cdr kons))) + pat-all-props)) + ;; list of (property . element) pairs, where element is a music expression + (element-list (filter (lambda (kons) (music? (cdr kons))) + pat-all-props)) + ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a + ;; list a music expressions + (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons))) + pat-all-props))) + (append ;; the binding form for the ?var variable found in pattern (first depth). ;; ?var is bound to the value of `expr' property (map (lambda (prop-var) - `(,(cdr prop-var) (ly:music-property ,expr ',(car prop-var)))) - prop-vars) + `(,(cdr prop-var) (ly:music-property ,expr ',(car prop-var)))) + prop-vars) ;; generate bindings for each element found in a (property . element) pair. ;; (typically, property will be 'element) (append-map (lambda (prop-element) - (gen-bindings `(ly:music-property ,expr ',(car prop-element)) - (cdr prop-element))) - element-list) + (gen-bindings `(ly:music-property ,expr ',(car prop-element)) + (cdr prop-element))) + element-list) ;; generate bindings for each element found in a (property . (e1 e2 ...)) pair ;; (typically, property will be 'elements) - (append-map (lambda (prop-elements) - (let ((index -1)) - (append-map (lambda (e) - (set! index (1+ index)) - (if (var? e) - `((,e (list-ref (ly:music-property ,expr ',(car prop-elements)) ,index))) - (gen-bindings `(list-ref (ly:music-property ,expr ',(car prop-elements)) - ,index) - e))) - (cdr prop-elements)))) - elements-list)))) + (append-map (lambda (prop-elements) + (let ((index -1)) + (append-map (lambda (e) + (set! index (1+ index)) + (if (var? e) + `((,e (list-ref (ly:music-property ,expr ',(car prop-elements)) ,index))) + (gen-bindings `(list-ref (ly:music-property ,expr ',(car prop-elements)) + ,index) + e))) + (cdr prop-elements)))) + elements-list)))) (define-macro (with-music-match music-expr+pattern . body) "If `music-expr' matches `pattern', call `body'. `pattern' should look like: @@ -255,24 +255,24 @@ Generate binding forms by looking for ?var symbol in pattern." property ?var1 element (music <MusicType> ...) elements ((music <MusicType> ...) - ?var2 - (music <MusicType> ...))) + ?var2 + (music <MusicType> ...))) The properties of `music-expr' are checked against the values given in the pattern (the name property being the <MusicType> symbol after the `music' keyword), then all music expression found in its properties (such as 'element or 'elements). When ?var is found instead of a property value, ?var is bound that property value, -as read inside `music-expr'. ?var may also be used to refere to a whole music -expression inside an elements list for instance. These bindings are accessible +as read inside `music-expr'. ?var may also be used to refere to a whole music +expression inside an elements list for instance. These bindings are accessible inside body." (let ((music-expr (first music-expr+pattern)) - (pattern (second music-expr+pattern)) - (expr-sym (gensym))) + (pattern (second music-expr+pattern)) + (expr-sym (gensym))) `(let ((,expr-sym ,music-expr)) (if ,(gen-condition expr-sym pattern) - (let ,(gen-bindings expr-sym pattern) - ,@body) - #f)))) + (let ,(gen-bindings expr-sym pattern) + ,@body) + #f)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -310,11 +310,11 @@ inside body." (define make-music-type-predicate-aux (lambda (mtypes) (lambda (expr) - (if (null? mtypes) - #f - (or (eqv? (car mtypes) (ly:music-property expr 'name)) - ((make-music-type-predicate-aux (cdr mtypes)) expr)))))) - (make-music-type-predicate-aux music-types)) + (if (null? mtypes) + #f + (or (eqv? (car mtypes) (ly:music-property expr 'name)) + ((make-music-type-predicate-aux (cdr mtypes)) expr)))))) + (make-music-type-predicate-aux music-types)) (ly:load "define-music-display-methods.scm") diff --git a/scm/display-woodwind-diagrams.scm b/scm/display-woodwind-diagrams.scm index 463e081009..c5eeaefbb3 100644 --- a/scm/display-woodwind-diagrams.scm +++ b/scm/display-woodwind-diagrams.scm @@ -64,10 +64,10 @@ (lambda (ls) (map (lambda (list-to-translate) `(,(list-ref list-to-translate 0) - . ,(map (lambda (name element) - `(,name . ,element)) - parameter-list - (list-tail list-to-translate 1)))) + . ,(map (lambda (name element) + `(,name . ,element)) + parameter-list + (list-tail list-to-translate 1)))) ls))) (define (get-named-spreadsheet-column column spreadsheet) @@ -77,8 +77,8 @@ @code{guile> (get-spreadsheet-column 'bar ((make-named-spreadsheet '(foo bar)) '((x . (1 2)) (y . (3 4)) (z . (5 6)))))} @code{((x . 2) (y . 4) (z . 6))}" (map - (lambda (row) (cons (car row) (assoc-get column (cdr row)))) - spreadsheet)) + (lambda (row) (cons (car row) (assoc-get column (cdr row)))) + spreadsheet)) (define make-key-alist (make-named-spreadsheet '(name offset graphical textual))) @@ -94,8 +94,8 @@ (define (make-central-column-hole-addresses keys) "Takes @code{keys} and ascribes them to the central column." (map - (lambda (key) `(central-column . ,key)) - keys)) + (lambda (key) `(central-column . ,key)) + keys)) (define (make-key-symbols hand) "Takes @code{hand} and ascribes @code{key} to it." @@ -111,63 +111,63 @@ (define flute-change-points ((make-named-spreadsheet '(piccolo flute flute-b-extension)) - `((bottom-group-key-names - . (((x - . ((offset . (-0.45 . -1.05)) - (stencil . ,piccolo-rh-x-key-stencil) - (text? . ("X" . #f)) - (complexity . trill)))) - ((cis - . ((offset . (0.0 . 0.0)) - (stencil . ,flute-rh-cis-key-stencil) - (text? . ("C" . 1)) - (complexity . trill))) - (c - . ((offset . (0.3 . 0.0)) - (stencil . ,flute-rh-c-key-stencil) - (text? . ("C" . #f)) - (complexity . trill))) - (gz - . ((offset . (0.0 . -1.2)) - (stencil . ,flute-rh-gz-key-stencil) - (text? . ("gz" . #f)) - (complexity . trill)))) - ((cis - . ((offset . (0.0 . 0.0)) - (stencil . ,flute-rh-cis-key-stencil) - (text? . ("C" . 1)) - (complexity . trill))) - (c - . ((offset . (0.3 . 0.0)) - (stencil . ,flute-rh-c-key-stencil) - (text? . ("C" . #f)) - (complexity . trill))) - (b - . ((offset . (1.0 . 0.0)) - (stencil . ,flute-rh-b-key-stencil) - (text? . ("B" . #f)) - (complexity . trill))) - (gz - . ((offset . (0.0 . -1.2)) - (stencil . ,flute-rh-gz-key-stencil) - (text? . ("gz" . #f)) - (complexity . trill)))))) - (bottom-group-graphical-stencil - . (((right-hand . ees) (right-hand . x)) - ,(make-right-hand-key-addresses '(ees cis c gz)) - ,(make-right-hand-key-addresses '(ees cis c b gz)))) + `((bottom-group-key-names + . (((x + . ((offset . (-0.45 . -1.05)) + (stencil . ,piccolo-rh-x-key-stencil) + (text? . ("X" . #f)) + (complexity . trill)))) + ((cis + . ((offset . (0.0 . 0.0)) + (stencil . ,flute-rh-cis-key-stencil) + (text? . ("C" . 1)) + (complexity . trill))) + (c + . ((offset . (0.3 . 0.0)) + (stencil . ,flute-rh-c-key-stencil) + (text? . ("C" . #f)) + (complexity . trill))) + (gz + . ((offset . (0.0 . -1.2)) + (stencil . ,flute-rh-gz-key-stencil) + (text? . ("gz" . #f)) + (complexity . trill)))) + ((cis + . ((offset . (0.0 . 0.0)) + (stencil . ,flute-rh-cis-key-stencil) + (text? . ("C" . 1)) + (complexity . trill))) + (c + . ((offset . (0.3 . 0.0)) + (stencil . ,flute-rh-c-key-stencil) + (text? . ("C" . #f)) + (complexity . trill))) + (b + . ((offset . (1.0 . 0.0)) + (stencil . ,flute-rh-b-key-stencil) + (text? . ("B" . #f)) + (complexity . trill))) + (gz + . ((offset . (0.0 . -1.2)) + (stencil . ,flute-rh-gz-key-stencil) + (text? . ("gz" . #f)) + (complexity . trill)))))) + (bottom-group-graphical-stencil + . (((right-hand . ees) (right-hand . x)) + ,(make-right-hand-key-addresses '(ees cis c gz)) + ,(make-right-hand-key-addresses '(ees cis c b gz)))) (bottom-group-graphical-draw-instruction - . (((right-hand . ees)) - ,(make-right-hand-key-addresses '(ees cis c)) - ,(make-right-hand-key-addresses '(ees cis c b)))) + . (((right-hand . ees)) + ,(make-right-hand-key-addresses '(ees cis c)) + ,(make-right-hand-key-addresses '(ees cis c b)))) (bottom-group-special-key-instruction . ((,rich-group-draw-rule ((right-hand . x)) ((right-hand . ees))) (,rich-group-draw-rule ((right-hand . gz)) ,(make-right-hand-key-addresses - '(ees cis c))) + '(ees cis c))) (,rich-group-draw-rule ((right-hand . gz)) ,(make-right-hand-key-addresses - '(ees cis c b))))) + '(ees cis c b))))) (bottom-group-text-stencil . (,(make-right-hand-key-addresses '(bes d dis ees x)) ,(make-right-hand-key-addresses '(bes d dis ees cis c gz)) @@ -177,153 +177,153 @@ (let* ((change-points (get-named-spreadsheet-column - flute-name - flute-change-points))) - `(,flute-name - . ((keys - . ((hidden - . ((midline - . ((offset . (0.0 . 0.0)) - (stencil . ,midline-stencil) - (text? . #f) - (complexity . basic))))) - (central-column - . ((one - . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))) - (two - . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))) - (three - . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))) - (four - . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))) - (five - . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))) - (six - . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))))) - (left-hand - . ((bes - . ((offset . (0.5 . 1.8)) - (stencil . ,flute-lh-bes-key-stencil) - (text? . ("B" . 0)) - (complexity . trill))) - (b - . ((offset . (0.0 . 0.0)) - (stencil . ,flute-lh-b-key-stencil) - (text? . ("B" . #f)) - (complexity . trill))) - (gis - . ((offset . (0.0 . 0.0)) - (stencil . ,flute-lh-gis-key-stencil) - (text? . ("G" . 1)) - (complexity . trill))))) - (right-hand - . ,(append `((bes - . ((offset . (0.0 . 0.0)) - (stencil . ,flute-rh-bes-key-stencil) - (text? . ("B" . 0)) - (complexity . trill))) - (d - . ((offset . (0.0 . 0.0)) - (stencil . ,flute-rh-d-key-stencil) - (text? . ("D" . #f)) - (complexity . trill))) - (dis - . ((offset . (0.0 . 0.0)) - (stencil . ,flute-rh-dis-key-stencil) - (text? . ("D" . 1)) - (complexity . trill))) - (ees - . ((offset . (1.5 . 1.3)) - (stencil . ,flute-rh-ees-key-stencil) - (text? . ("E" . 0)) - (complexity . trill)))) - (assoc-get 'bottom-group-key-names change-points))))) - (graphical-commands - . ((stencil-alist - . ((stencils - . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) - ((stencils - . ,(make-central-column-hole-addresses + flute-name + flute-change-points))) + `(,flute-name + . ((keys + . ((hidden + . ((midline + . ((offset . (0.0 . 0.0)) + (stencil . ,midline-stencil) + (text? . #f) + (complexity . basic))))) + (central-column + . ((one + . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))) + (two + . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))) + (three + . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))) + (four + . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))) + (five + . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))) + (six + . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))))) + (left-hand + . ((bes + . ((offset . (0.5 . 1.8)) + (stencil . ,flute-lh-bes-key-stencil) + (text? . ("B" . 0)) + (complexity . trill))) + (b + . ((offset . (0.0 . 0.0)) + (stencil . ,flute-lh-b-key-stencil) + (text? . ("B" . #f)) + (complexity . trill))) + (gis + . ((offset . (0.0 . 0.0)) + (stencil . ,flute-lh-gis-key-stencil) + (text? . ("G" . 1)) + (complexity . trill))))) + (right-hand + . ,(append `((bes + . ((offset . (0.0 . 0.0)) + (stencil . ,flute-rh-bes-key-stencil) + (text? . ("B" . 0)) + (complexity . trill))) + (d + . ((offset . (0.0 . 0.0)) + (stencil . ,flute-rh-d-key-stencil) + (text? . ("D" . #f)) + (complexity . trill))) + (dis + . ((offset . (0.0 . 0.0)) + (stencil . ,flute-rh-dis-key-stencil) + (text? . ("D" . 1)) + (complexity . trill))) + (ees + . ((offset . (1.5 . 1.3)) + (stencil . ,flute-rh-ees-key-stencil) + (text? . ("E" . 0)) + (complexity . trill)))) + (assoc-get 'bottom-group-key-names change-points))))) + (graphical-commands + . ((stencil-alist + . ((stencils + . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) + ((stencils + . ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0))) - ((stencils . ((left-hand . bes) (left-hand . b))) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (-1.5 . 6.5))) - ,(simple-stencil-alist '(left-hand . gis) '(1.0 . 4.0)) - ,(simple-stencil-alist '(right-hand . bes) '(-1.75 . 3.05)) - ,(simple-stencil-alist '(right-hand . d) '(-1.0 . 2.5)) - ,(simple-stencil-alist '(right-hand . dis) '(-1.0 . 1.5)) - ((stencils - . ,(assoc-get 'bottom-group-graphical-stencil - change-points)) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (0.0 . -0.6))))) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0)))) - (draw-instructions - . ((,apply-group-draw-rule-series - (((left-hand . bes) (left-hand . b)) - ,(assoc-get 'bottom-group-graphical-draw-instruction - change-points))) - ,(assoc-get 'bottom-group-special-key-instruction - change-points) - (,group-automate-rule - ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) - (,group-automate-rule ((hidden . midline))))) - (extra-offset-instructions - . ((,uniform-extra-offset-rule (0.0 . 0.0)))))) - (text-commands - . ((stencil-alist - . ((stencils - . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) - ((stencils - . ,(make-central-column-hole-addresses + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0))) + ((stencils . ((left-hand . bes) (left-hand . b))) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (-1.5 . 6.5))) + ,(simple-stencil-alist '(left-hand . gis) '(1.0 . 4.0)) + ,(simple-stencil-alist '(right-hand . bes) '(-1.75 . 3.05)) + ,(simple-stencil-alist '(right-hand . d) '(-1.0 . 2.5)) + ,(simple-stencil-alist '(right-hand . dis) '(-1.0 . 1.5)) + ((stencils + . ,(assoc-get 'bottom-group-graphical-stencil + change-points)) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (0.0 . -0.6))))) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0)))) + (draw-instructions + . ((,apply-group-draw-rule-series + (((left-hand . bes) (left-hand . b)) + ,(assoc-get 'bottom-group-graphical-draw-instruction + change-points))) + ,(assoc-get 'bottom-group-special-key-instruction + change-points) + (,group-automate-rule + ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) + (,group-automate-rule ((hidden . midline))))) + (extra-offset-instructions + . ((,uniform-extra-offset-rule (0.0 . 0.0)))))) + (text-commands + . ((stencil-alist + . ((stencils + . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) + ((stencils + . ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0))) - ((stencils . ,(make-left-hand-key-addresses '(bes b gis))) - (textual? . ,lh-woodwind-text-stencil) - (offset . (1.5 . 3.75))) - ((stencils . ,(assoc-get 'bottom-group-text-stencil - change-points)) - (textual? . ,rh-woodwind-text-stencil) - (offset . (-1.25 . 0.0))))) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0)))) - (draw-instructions - . ((,apply-group-draw-rule-series - (,(make-left-hand-key-addresses '(bes b gis)) - ,(assoc-get 'bottom-group-text-stencil change-points))) - (,group-automate-rule - ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) - (,group-automate-rule ((hidden . midline))))) - (extra-offset-instructions - . ((,uniform-extra-offset-rule (0.0 . 0.0)))))))))) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0))) + ((stencils . ,(make-left-hand-key-addresses '(bes b gis))) + (textual? . ,lh-woodwind-text-stencil) + (offset . (1.5 . 3.75))) + ((stencils . ,(assoc-get 'bottom-group-text-stencil + change-points)) + (textual? . ,rh-woodwind-text-stencil) + (offset . (-1.25 . 0.0))))) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0)))) + (draw-instructions + . ((,apply-group-draw-rule-series + (,(make-left-hand-key-addresses '(bes b gis)) + ,(assoc-get 'bottom-group-text-stencil change-points))) + (,group-automate-rule + ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) + (,group-automate-rule ((hidden . midline))))) + (extra-offset-instructions + . ((,uniform-extra-offset-rule (0.0 . 0.0)))))))))) ;;; Tin whistle assembly instructions @@ -332,87 +332,87 @@ (define (generate-tin-whistle-family-entry tin-whistle-name) (let* - ((change-points - (get-named-spreadsheet-column tin-whistle-name tin-whistle-change-points))) - `(,tin-whistle-name - . ((keys - . ((hidden - . ((midline - . ((offset . (0.0 . 0.0)) - (stencil . ,midline-stencil) - (text? . #f) - (complexity . basic))))) - (central-column - . ((one - . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . covered))) - (two - . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . covered))) - (three - . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . covered))) - (four - . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . covered))) - (five - . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . covered))) - (six - . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . covered))))) - (left-hand . ()) - (right-hand . ()))) - (graphical-commands - . ((stencil-alist - . ((stencils - . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) - ((stencils - . ,(make-central-column-hole-addresses - CENTRAL-COLUMN-HOLE-LIST)) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0))))) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0)))) - (draw-instructions - . ((,group-automate-rule - ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) - (,group-automate-rule ((hidden . midline))))) - (extra-offset-instructions - . ((,uniform-extra-offset-rule (0.0 . 0.0)))))) - (text-commands - . ((stencil-alist - . ((stencils . - (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) - ((stencils - . ,(make-central-column-hole-addresses - CENTRAL-COLUMN-HOLE-H-LIST)) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0))))) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0)))) - (draw-instructions - . ((,group-automate-rule - ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) - (,group-automate-rule ((hidden . midline))))) - (extra-offset-instructions - . ((,uniform-extra-offset-rule (0.0 . 0.0)))))))))) + ((change-points + (get-named-spreadsheet-column tin-whistle-name tin-whistle-change-points))) + `(,tin-whistle-name + . ((keys + . ((hidden + . ((midline + . ((offset . (0.0 . 0.0)) + (stencil . ,midline-stencil) + (text? . #f) + (complexity . basic))))) + (central-column + . ((one + . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . covered))) + (two + . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . covered))) + (three + . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . covered))) + (four + . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . covered))) + (five + . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . covered))) + (six + . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . covered))))) + (left-hand . ()) + (right-hand . ()))) + (graphical-commands + . ((stencil-alist + . ((stencils + . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) + ((stencils + . ,(make-central-column-hole-addresses + CENTRAL-COLUMN-HOLE-LIST)) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0))))) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0)))) + (draw-instructions + . ((,group-automate-rule + ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) + (,group-automate-rule ((hidden . midline))))) + (extra-offset-instructions + . ((,uniform-extra-offset-rule (0.0 . 0.0)))))) + (text-commands + . ((stencil-alist + . ((stencils . + (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) + ((stencils + . ,(make-central-column-hole-addresses + CENTRAL-COLUMN-HOLE-H-LIST)) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0))))) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0)))) + (draw-instructions + . ((,group-automate-rule + ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) + (,group-automate-rule ((hidden . midline))))) + (extra-offset-instructions + . ((,uniform-extra-offset-rule (0.0 . 0.0)))))))))) ;;; Oboe assembly instructions @@ -421,600 +421,600 @@ (define (generate-oboe-family-entry oboe-name) (let* - ((change-points - (get-named-spreadsheet-column oboe-name oboe-change-points))) - `(,oboe-name - . ((keys - . ((hidden - . ((midline - . ((offset . (0.0 . 0.0)) - (stencil . ,midline-stencil) - (text? . #f) - (complexity . basic))))) - (central-column - . ((one - . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))) - (two - . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))) - (three - . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))) - (four - . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))) - (five - . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))) - (six - . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))) - (h - . ((offset . (0.0 . 6.25)) - (stencil . ,(variable-column-circle-stencil 0.4)) - (text? . #f) - (complexity . trill))))) - (left-hand - . ((I - . ((offset . (0.0 . 0.0)) - (stencil . ,oboe-lh-I-key-stencil) - (text? . ("I" . #f)) - (complexity . trill))) - (III - . ((offset . (0.0 . 2.6)) - (stencil . ,oboe-lh-III-key-stencil) - (text? . ("III" . #f)) - (complexity . trill))) - (II - . ((offset . (0.0 . 0.0)) - (stencil . ,oboe-lh-II-key-stencil) - (text? . ("II" . #f)) - (complexity . trill))) - (b - . ((offset . (0.0 . 0.0)) - (stencil . ,oboe-lh-b-key-stencil) - (text? . ("B" . #f)) - (complexity . trill))) - (d - . ((offset . (0.0 . 0.0)) - (stencil . ,oboe-lh-d-key-stencil) - (text? . ("D" . #f)) - (complexity . trill))) - (cis - . ((offset . (0.0 . 0.0)) - (stencil . ,oboe-lh-cis-key-stencil) - (text? . ("C" . 1)) - (complexity . trill))) - (gis - . ((offset . (-0.85 . 0.2)) - (stencil . ,oboe-lh-gis-key-stencil) - (text? . ("G" . 1)) - (complexity . trill))) - (ees - . ((offset . (2.05 . -3.65)) - (stencil . ,oboe-lh-ees-key-stencil) - (text? . ("E" . 0)) - (complexity . trill))) - (low-b - . ((offset . (3.6 . 0.5)) - (stencil . ,oboe-lh-low-b-key-stencil) - (text? . ("b" . #f)) - (complexity . trill))) - (bes - . ((offset . (2.25 . -4.15)) - (stencil . ,oboe-lh-bes-key-stencil) - (text? . ("B" . 0)) - (complexity . trill))) - (f - . ((offset . (2.15 . -3.85)) - (stencil . ,oboe-lh-f-key-stencil) - (text? . ("F" . #f)) - (complexity . trill))))) - (right-hand - . ((a - . ((offset . (1.5 . 1.2)) - (stencil . ,oboe-rh-a-key-stencil) - (text? . ("A" . #f)) - (complexity . trill))) - (gis - . ((offset . (0.0 . 0.0)) - (stencil . ,oboe-rh-gis-key-stencil) - (text? . ("G" . 1)) - (complexity . trill))) - (d - . ((offset . (0.0 . 0.0)) - (stencil . ,oboe-rh-d-key-stencil) - (text? . ("D" . #f)) - (complexity . trill))) - (f - . ((offset . (0.0 . 0.0)) - (stencil . ,oboe-rh-f-key-stencil) - (text? . ("F" . #f)) - (complexity . trill))) - (banana - . ((offset . (0.0 . 0.0)) - (stencil . ,oboe-rh-banana-key-stencil) - (text? . ("ban" . #f)) - (complexity . trill))) - (c - . ((offset . (0.0 . 0.0)) - (stencil . ,oboe-rh-c-key-stencil) - (text? . ("C" . #f)) - (complexity . trill))) - (cis - . ((offset . (3.8 . -0.6)) - (stencil . ,oboe-rh-cis-key-stencil) - (text? . ("C" . 1)) - (complexity . trill))) - (ees - . ((offset . (0.0 . -1.8)) - (stencil . ,oboe-rh-ees-key-stencil) - (text? . ("E" . 0)) - (complexity . trill))))))) - (graphical-commands - . ((stencil-alist - . ((stencils - . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) - ((stencils - . ,(make-central-column-hole-addresses - CENTRAL-COLUMN-HOLE-H-LIST)) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0))) - ((stencils . ((left-hand . I) (left-hand . III))) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (-2.5 . 6.5))) - ,(simple-stencil-alist '(left-hand . II) '(2.5 . 6.0)) - ,(simple-stencil-alist '(left-hand . b) '(-1.35 . 6.0)) - ,(simple-stencil-alist '(left-hand . d) '(1.0 . 6.0)) - ,(simple-stencil-alist '(left-hand . cis) '(1.0 . 5.0)) - ((stencils - . ,(make-left-hand-key-addresses '(gis bes low-b ees f))) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (0.0 . 3.9))) - ((stencils . - ,(make-right-hand-key-addresses '(a gis))) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (-3.5 . 3.5))) - ,(simple-stencil-alist '(right-hand . d) '(1.0 . 2.5)) - ,(simple-stencil-alist '(right-hand . f) '(-1.0 . 1.5)) - ,(simple-stencil-alist '(right-hand . banana) '(1.7 . 1.0)) - ((stencils . ,(make-right-hand-key-addresses '(c cis ees))) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (-3.4 . 0.3))))) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0)))) - (draw-instructions - . ((,apply-group-draw-rule-series - (((right-hand . a) (right-hand . gis)) - ,(make-left-hand-key-addresses '(gis bes low-b ees)) - ,(make-right-hand-key-addresses '(cis c ees)))) - (,rich-group-draw-rule - ((left-hand . III)) - ((left-hand . I))) - (,rich-group-draw-rule - ((left-hand . f)) - ,(make-left-hand-key-addresses '(gis bes low-b ees))) - (,group-automate-rule - ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) - (,group-automate-rule ((hidden . midline))))) - (extra-offset-instructions - . ((,rich-group-extra-offset-rule - ((central-column . h)) ((central-column . one)) (0.0 . 0.8)) - (,uniform-extra-offset-rule (0.0 . 0.0)))))) - (text-commands - . ((stencil-alist - . ((stencils . - (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) - ((stencils - . ,(make-central-column-hole-addresses - CENTRAL-COLUMN-HOLE-H-LIST)) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0))) - ((stencils . ,(make-left-hand-key-addresses '(III I))) - (textual? . ,lh-woodwind-text-stencil) - (offset . (-2.8 . 7.0))) - ((stencils . ,(make-left-hand-key-addresses '(II))) - (textual? . ,lh-woodwind-text-stencil) - (offset . (2.2 . 7.0))) - ((stencils - . ,(make-left-hand-key-addresses - '(b d cis gis ees low-b bes f))) - (textual? . ,lh-woodwind-text-stencil) - (offset . (1.5 . 3.75))) - ((stencils - . ,(make-right-hand-key-addresses - '(a gis d f banana c cis ees))) - (textual? . ,rh-woodwind-text-stencil) - (offset . (-1.25 . 0.0))))) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0)))) - (draw-instructions - . ((,apply-group-draw-rule-series - (,(make-left-hand-key-addresses '(b d cis gis ees low-b bes f)) - ,(make-left-hand-key-addresses '(III I)) - ,(make-right-hand-key-addresses '(a gis d f banana c cis ees)))) - (,group-automate-rule - ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) - (,group-automate-rule ((hidden . midline))))) - (extra-offset-instructions - . ((,rich-group-extra-offset-rule - ((central-column . h)) - ((central-column . one)) - (0.0 . 0.8)) - (,uniform-extra-offset-rule (0.0 . 0.0)))))))))) + ((change-points + (get-named-spreadsheet-column oboe-name oboe-change-points))) + `(,oboe-name + . ((keys + . ((hidden + . ((midline + . ((offset . (0.0 . 0.0)) + (stencil . ,midline-stencil) + (text? . #f) + (complexity . basic))))) + (central-column + . ((one + . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))) + (two + . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))) + (three + . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))) + (four + . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))) + (five + . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))) + (six + . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))) + (h + . ((offset . (0.0 . 6.25)) + (stencil . ,(variable-column-circle-stencil 0.4)) + (text? . #f) + (complexity . trill))))) + (left-hand + . ((I + . ((offset . (0.0 . 0.0)) + (stencil . ,oboe-lh-I-key-stencil) + (text? . ("I" . #f)) + (complexity . trill))) + (III + . ((offset . (0.0 . 2.6)) + (stencil . ,oboe-lh-III-key-stencil) + (text? . ("III" . #f)) + (complexity . trill))) + (II + . ((offset . (0.0 . 0.0)) + (stencil . ,oboe-lh-II-key-stencil) + (text? . ("II" . #f)) + (complexity . trill))) + (b + . ((offset . (0.0 . 0.0)) + (stencil . ,oboe-lh-b-key-stencil) + (text? . ("B" . #f)) + (complexity . trill))) + (d + . ((offset . (0.0 . 0.0)) + (stencil . ,oboe-lh-d-key-stencil) + (text? . ("D" . #f)) + (complexity . trill))) + (cis + . ((offset . (0.0 . 0.0)) + (stencil . ,oboe-lh-cis-key-stencil) + (text? . ("C" . 1)) + (complexity . trill))) + (gis + . ((offset . (-0.85 . 0.2)) + (stencil . ,oboe-lh-gis-key-stencil) + (text? . ("G" . 1)) + (complexity . trill))) + (ees + . ((offset . (2.05 . -3.65)) + (stencil . ,oboe-lh-ees-key-stencil) + (text? . ("E" . 0)) + (complexity . trill))) + (low-b + . ((offset . (3.6 . 0.5)) + (stencil . ,oboe-lh-low-b-key-stencil) + (text? . ("b" . #f)) + (complexity . trill))) + (bes + . ((offset . (2.25 . -4.15)) + (stencil . ,oboe-lh-bes-key-stencil) + (text? . ("B" . 0)) + (complexity . trill))) + (f + . ((offset . (2.15 . -3.85)) + (stencil . ,oboe-lh-f-key-stencil) + (text? . ("F" . #f)) + (complexity . trill))))) + (right-hand + . ((a + . ((offset . (1.5 . 1.2)) + (stencil . ,oboe-rh-a-key-stencil) + (text? . ("A" . #f)) + (complexity . trill))) + (gis + . ((offset . (0.0 . 0.0)) + (stencil . ,oboe-rh-gis-key-stencil) + (text? . ("G" . 1)) + (complexity . trill))) + (d + . ((offset . (0.0 . 0.0)) + (stencil . ,oboe-rh-d-key-stencil) + (text? . ("D" . #f)) + (complexity . trill))) + (f + . ((offset . (0.0 . 0.0)) + (stencil . ,oboe-rh-f-key-stencil) + (text? . ("F" . #f)) + (complexity . trill))) + (banana + . ((offset . (0.0 . 0.0)) + (stencil . ,oboe-rh-banana-key-stencil) + (text? . ("ban" . #f)) + (complexity . trill))) + (c + . ((offset . (0.0 . 0.0)) + (stencil . ,oboe-rh-c-key-stencil) + (text? . ("C" . #f)) + (complexity . trill))) + (cis + . ((offset . (3.8 . -0.6)) + (stencil . ,oboe-rh-cis-key-stencil) + (text? . ("C" . 1)) + (complexity . trill))) + (ees + . ((offset . (0.0 . -1.8)) + (stencil . ,oboe-rh-ees-key-stencil) + (text? . ("E" . 0)) + (complexity . trill))))))) + (graphical-commands + . ((stencil-alist + . ((stencils + . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) + ((stencils + . ,(make-central-column-hole-addresses + CENTRAL-COLUMN-HOLE-H-LIST)) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0))) + ((stencils . ((left-hand . I) (left-hand . III))) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (-2.5 . 6.5))) + ,(simple-stencil-alist '(left-hand . II) '(2.5 . 6.0)) + ,(simple-stencil-alist '(left-hand . b) '(-1.35 . 6.0)) + ,(simple-stencil-alist '(left-hand . d) '(1.0 . 6.0)) + ,(simple-stencil-alist '(left-hand . cis) '(1.0 . 5.0)) + ((stencils + . ,(make-left-hand-key-addresses '(gis bes low-b ees f))) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (0.0 . 3.9))) + ((stencils . + ,(make-right-hand-key-addresses '(a gis))) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (-3.5 . 3.5))) + ,(simple-stencil-alist '(right-hand . d) '(1.0 . 2.5)) + ,(simple-stencil-alist '(right-hand . f) '(-1.0 . 1.5)) + ,(simple-stencil-alist '(right-hand . banana) '(1.7 . 1.0)) + ((stencils . ,(make-right-hand-key-addresses '(c cis ees))) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (-3.4 . 0.3))))) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0)))) + (draw-instructions + . ((,apply-group-draw-rule-series + (((right-hand . a) (right-hand . gis)) + ,(make-left-hand-key-addresses '(gis bes low-b ees)) + ,(make-right-hand-key-addresses '(cis c ees)))) + (,rich-group-draw-rule + ((left-hand . III)) + ((left-hand . I))) + (,rich-group-draw-rule + ((left-hand . f)) + ,(make-left-hand-key-addresses '(gis bes low-b ees))) + (,group-automate-rule + ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) + (,group-automate-rule ((hidden . midline))))) + (extra-offset-instructions + . ((,rich-group-extra-offset-rule + ((central-column . h)) ((central-column . one)) (0.0 . 0.8)) + (,uniform-extra-offset-rule (0.0 . 0.0)))))) + (text-commands + . ((stencil-alist + . ((stencils . + (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) + ((stencils + . ,(make-central-column-hole-addresses + CENTRAL-COLUMN-HOLE-H-LIST)) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0))) + ((stencils . ,(make-left-hand-key-addresses '(III I))) + (textual? . ,lh-woodwind-text-stencil) + (offset . (-2.8 . 7.0))) + ((stencils . ,(make-left-hand-key-addresses '(II))) + (textual? . ,lh-woodwind-text-stencil) + (offset . (2.2 . 7.0))) + ((stencils + . ,(make-left-hand-key-addresses + '(b d cis gis ees low-b bes f))) + (textual? . ,lh-woodwind-text-stencil) + (offset . (1.5 . 3.75))) + ((stencils + . ,(make-right-hand-key-addresses + '(a gis d f banana c cis ees))) + (textual? . ,rh-woodwind-text-stencil) + (offset . (-1.25 . 0.0))))) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0)))) + (draw-instructions + . ((,apply-group-draw-rule-series + (,(make-left-hand-key-addresses '(b d cis gis ees low-b bes f)) + ,(make-left-hand-key-addresses '(III I)) + ,(make-right-hand-key-addresses '(a gis d f banana c cis ees)))) + (,group-automate-rule + ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) + (,group-automate-rule ((hidden . midline))))) + (extra-offset-instructions + . ((,rich-group-extra-offset-rule + ((central-column . h)) + ((central-column . one)) + (0.0 . 0.8)) + (,uniform-extra-offset-rule (0.0 . 0.0)))))))))) ;; Clarinet assembly instructions (define clarinet-change-points ((make-named-spreadsheet '(clarinet bass-clarinet low-bass-clarinet)) - `((bottom-group-key-names - . (() - ((ees - . ((offset . (0.0 . ,(* 0 (+ 0.75 CL-RH-HAIR)))) - (stencil . ,bass-clarinet-rh-ees-key-stencil) - (text? . ("E" . 0)) - (complexity . trill)))) - ((ees - . ((offset . (0.0 . ,(* 0 (+ 0.75 CL-RH-HAIR)))) - (stencil . ,low-bass-clarinet-rh-ees-key-stencil) - (text? . ("E" . 0)) - (complexity . trill))) - (d - . ((offset . (,(+ 1.5 CL-RH-HAIR) . ,(* -1 (+ 0.75 CL-RH-HAIR)))) - (stencil . ,clarinet-rh-d-key-stencil) - (text? . ("d" . #f)) - (complexity . trill))) - (low-cis - . ((offset . (0.0 . 1.4)) - (stencil . ,clarinet-rh-low-cis-key-stencil) - (text? . ("c" . 1)) - (complexity . trill))) - (low-d - . ((offset . (0.0 . 2.4)) - (stencil . ,clarinet-rh-low-d-key-stencil) - (text? . ("d" . #f)) - (complexity . trill))) - (low-c - . ((offset . (0.0 . 0.0)) - (stencil . ,clarinet-rh-low-c-key-stencil) - (text? . ("c" . #f)) - (complexity . trill)))))) - (left-extra-key-names - . (() - () - ((d - . ((offset . (4.0 . -0.8)) - (stencil . ,clarinet-lh-d-key-stencil) - (text? . ("D" . #f)) - (complexity . trill)))))) - (right-thumb-group - . (() - () - (((stencils + `((bottom-group-key-names + . (() + ((ees + . ((offset . (0.0 . ,(* 0 (+ 0.75 CL-RH-HAIR)))) + (stencil . ,bass-clarinet-rh-ees-key-stencil) + (text? . ("E" . 0)) + (complexity . trill)))) + ((ees + . ((offset . (0.0 . ,(* 0 (+ 0.75 CL-RH-HAIR)))) + (stencil . ,low-bass-clarinet-rh-ees-key-stencil) + (text? . ("E" . 0)) + (complexity . trill))) + (d + . ((offset . (,(+ 1.5 CL-RH-HAIR) . ,(* -1 (+ 0.75 CL-RH-HAIR)))) + (stencil . ,clarinet-rh-d-key-stencil) + (text? . ("d" . #f)) + (complexity . trill))) + (low-cis + . ((offset . (0.0 . 1.4)) + (stencil . ,clarinet-rh-low-cis-key-stencil) + (text? . ("c" . 1)) + (complexity . trill))) + (low-d + . ((offset . (0.0 . 2.4)) + (stencil . ,clarinet-rh-low-d-key-stencil) + (text? . ("d" . #f)) + (complexity . trill))) + (low-c + . ((offset . (0.0 . 0.0)) + (stencil . ,clarinet-rh-low-c-key-stencil) + (text? . ("c" . #f)) + (complexity . trill)))))) + (left-extra-key-names + . (() + () + ((d + . ((offset . (4.0 . -0.8)) + (stencil . ,clarinet-lh-d-key-stencil) + (text? . ("D" . #f)) + (complexity . trill)))))) + (right-thumb-group + . (() + () + (((stencils . ,(make-right-hand-key-addresses '(low-c low-cis))) (xy-scale-function . (,return-1 . ,return-1)) (textual? . #f) (offset . (-1.3 . 4.0)))))) - (low-left-hand-key-addresses - . (,(make-left-hand-key-addresses '(cis f e fis)) - ,(make-left-hand-key-addresses '(cis f e fis)) - ,(make-left-hand-key-addresses '(cis f e fis d)))) - (all-left-hand-key-addresses - . (,(make-left-hand-key-addresses '(a gis ees cis f e fis)) - ,(make-left-hand-key-addresses '(a gis ees cis f e fis)) - ,(make-left-hand-key-addresses '(a gis ees cis f e fis d)))) - (low-key-group - . (() - () - (,(make-right-hand-key-addresses '(low-c low-cis))))) - (low-rich-draw-rules - . (() - () - ((,rich-group-draw-rule - ((left-hand . d)) - ,(make-left-hand-key-addresses '(cis f e fis))) - (,rich-group-draw-rule - ((right-hand . low-d)) - ((right-hand . low-cis) (right-hand . low-c)))))) - (low-extra-offset-rule - . (() - () - ((,rich-group-extra-offset-rule - ,(make-right-hand-key-addresses '(low-c low-d low-cis)) - ,(make-right-hand-key-addresses '(one two three four)) - (-0.5 . -0.7))))) - (bottom-right-group-key-addresses - . (,(make-right-hand-key-addresses '(fis e f gis)) - ,(make-right-hand-key-addresses '(fis e ees gis f)) - ,(make-right-hand-key-addresses '(fis e ees gis f d)))) - (right-hand-key-addresses - . (,(make-right-hand-key-addresses '(fis e f gis)) - ,(make-right-hand-key-addresses '(fis e ees gis f)) - ,(make-right-hand-key-addresses - '(low-d low-cis low-c fis e ees gis f d))))))) + (low-left-hand-key-addresses + . (,(make-left-hand-key-addresses '(cis f e fis)) + ,(make-left-hand-key-addresses '(cis f e fis)) + ,(make-left-hand-key-addresses '(cis f e fis d)))) + (all-left-hand-key-addresses + . (,(make-left-hand-key-addresses '(a gis ees cis f e fis)) + ,(make-left-hand-key-addresses '(a gis ees cis f e fis)) + ,(make-left-hand-key-addresses '(a gis ees cis f e fis d)))) + (low-key-group + . (() + () + (,(make-right-hand-key-addresses '(low-c low-cis))))) + (low-rich-draw-rules + . (() + () + ((,rich-group-draw-rule + ((left-hand . d)) + ,(make-left-hand-key-addresses '(cis f e fis))) + (,rich-group-draw-rule + ((right-hand . low-d)) + ((right-hand . low-cis) (right-hand . low-c)))))) + (low-extra-offset-rule + . (() + () + ((,rich-group-extra-offset-rule + ,(make-right-hand-key-addresses '(low-c low-d low-cis)) + ,(make-right-hand-key-addresses '(one two three four)) + (-0.5 . -0.7))))) + (bottom-right-group-key-addresses + . (,(make-right-hand-key-addresses '(fis e f gis)) + ,(make-right-hand-key-addresses '(fis e ees gis f)) + ,(make-right-hand-key-addresses '(fis e ees gis f d)))) + (right-hand-key-addresses + . (,(make-right-hand-key-addresses '(fis e f gis)) + ,(make-right-hand-key-addresses '(fis e ees gis f)) + ,(make-right-hand-key-addresses + '(low-d low-cis low-c fis e ees gis f d))))))) (define (generate-clarinet-family-entry clarinet-name) (let* - ((change-points - (get-named-spreadsheet-column clarinet-name clarinet-change-points))) - `(,clarinet-name - . ((keys - . ((hidden - . ((midline - . ((offset . (0.0 . 0.0)) - (stencil . ,midline-stencil) - (text? . #f) - (complexity . basic))))) - (central-column - . ((one - . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . covered))) - (two - . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . covered))) - (three - . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . covered))) - (four - . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . covered))) - (five - . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . covered))) - (six - . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . covered))) - (h - . ((offset . (0.0 . 6.25)) - (stencil . ,(variable-column-circle-stencil 0.4)) - (text? . #f) - (complexity . covered))))) - (left-hand - . ,(append `((thumb - . ((offset . (0.0 . 0.0)) - (stencil . ,clarinet-lh-thumb-key-stencil) - (text? . #f) - (complexity . trill))) - (R - . ((offset . (1.0 . 1.0)) - (stencil . ,clarinet-lh-R-key-stencil) - (text? . #f) - (complexity . trill))) - (a - . ((offset . (0.0 . 0.0)) - (stencil . ,clarinet-lh-a-key-stencil) - (text? . ("A" . #f)) - (complexity . trill))) - (gis - . ((offset . (0.8 . 1.0)) - (stencil . ,clarinet-lh-gis-key-stencil) - (text? . ("G" . 1)) - (complexity . trill))) - (ees - . ((offset . (0.0 . 0.0)) - (stencil . ,clarinet-lh-ees-key-stencil) - (text? . ("E" . 0)) - (complexity . trill))) - (cis - . ((offset . (-0.85 . 0.2)) - (stencil . ,clarinet-lh-cis-key-stencil) - (text? . ("C" . 1)) - (complexity . trill))) - (f - . ((offset . (3.6 . 0.5)) - (stencil . ,clarinet-lh-f-key-stencil) - (text? . ("F" . #f)) - (complexity . trill))) - (e - . ((offset . (2.05 . -3.65)) - (stencil . ,clarinet-lh-e-key-stencil) - (text? . ("E" . #f)) - (complexity . trill))) - (fis - . ((offset . (2.25 . -4.15)) - (stencil . ,clarinet-lh-fis-key-stencil) - (text? . ("F" . 1)) - (complexity . trill)))) - (assoc-get 'left-extra-key-names change-points))) - (right-hand - . ,(append `((one - . ((offset . (0.0 . 0.75)) - (stencil . ,clarinet-rh-one-key-stencil) - (text? . "1") - (complexity . trill))) - (two - . ((offset . (0.0 . 0.25)) - (stencil . ,clarinet-rh-two-key-stencil) - (text? . "2") - (complexity . trill))) - (three - . ((offset . (0.0 . -0.25)) - (stencil . ,clarinet-rh-three-key-stencil) - (text? . "3") - (complexity . trill))) - (four - . ((offset . (0.0 . -0.75)) - (stencil . ,clarinet-rh-four-key-stencil) - (text? . "4") - (complexity . trill))) - (b - . ((offset . (0.0 . 0.0)) - (stencil . ,clarinet-rh-b-key-stencil) - (text? . ("B" . #f)) - (complexity . trill))) - (fis - . ((offset . (0.0 . ,(* 4 (+ 0.75 CL-RH-HAIR)))) - (stencil . ,clarinet-rh-fis-key-stencil) - (text? . ("F" . 1)) - (complexity . trill))) - (gis - . ((offset . (,(+ 1.5 CL-RH-HAIR) - . ,(* 3 (+ 0.75 CL-RH-HAIR)))) - (stencil . ,clarinet-rh-gis-key-stencil) - (text? . ("G" . 1)) - (complexity . trill))) - (e - . ((offset . (0.0 . ,(* 2 (+ 0.75 CL-RH-HAIR)))) - (stencil . ,clarinet-rh-e-key-stencil) - (text? . ("E" . #f)) - (complexity . trill))) - (f - . ((offset . (,(+ 1.5 CL-RH-HAIR) - . ,(* 1 (+ 0.75 CL-RH-HAIR)))) - (stencil . ,clarinet-rh-f-key-stencil) - (text? . ("F" . #f)) - (complexity . trill)))) - (assoc-get 'bottom-group-key-names change-points))))) - (graphical-commands - . ((stencil-alist - . ((stencils - . ,(append (assoc-get 'right-thumb-group change-points) - `(,(simple-stencil-alist '(hidden . midline) - '(0.0 . 3.75)) - ((stencils - . ,(make-central-column-hole-addresses - CENTRAL-COLUMN-HOLE-H-LIST)) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0))) - ((stencils - . ,(make-left-hand-key-addresses '(thumb R))) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (-2.5 . 6.5))) - ((stencils - . ((left-hand . a) (left-hand . gis))) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (0.0 . 7.5))) - ,(simple-stencil-alist '(left-hand . ees) - '(1.0 . 5.0)) - ((stencils - . ,(make-left-hand-key-addresses '(cis f e fis))) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (0.0 . 3.9))) - ((stencils - . ,(make-right-hand-key-addresses - '(one two three four))) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (-1.25 . 3.75))) - ,(simple-stencil-alist '(right-hand . b) - '(-1.0 . 1.5)) - ((stencils - . ,(assoc-get 'bottom-right-group-key-addresses - change-points)) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (-4.0 . -0.75)))))) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0)))) - (draw-instructions - . ,(append (assoc-get 'low-rich-draw-rules change-points) - `((,apply-group-draw-rule-series - ,(append (assoc-get 'low-key-group change-points) - `(((left-hand . a) (left-hand . gis)) - ,(make-right-hand-key-addresses + ((change-points + (get-named-spreadsheet-column clarinet-name clarinet-change-points))) + `(,clarinet-name + . ((keys + . ((hidden + . ((midline + . ((offset . (0.0 . 0.0)) + (stencil . ,midline-stencil) + (text? . #f) + (complexity . basic))))) + (central-column + . ((one + . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . covered))) + (two + . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . covered))) + (three + . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . covered))) + (four + . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . covered))) + (five + . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . covered))) + (six + . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . covered))) + (h + . ((offset . (0.0 . 6.25)) + (stencil . ,(variable-column-circle-stencil 0.4)) + (text? . #f) + (complexity . covered))))) + (left-hand + . ,(append `((thumb + . ((offset . (0.0 . 0.0)) + (stencil . ,clarinet-lh-thumb-key-stencil) + (text? . #f) + (complexity . trill))) + (R + . ((offset . (1.0 . 1.0)) + (stencil . ,clarinet-lh-R-key-stencil) + (text? . #f) + (complexity . trill))) + (a + . ((offset . (0.0 . 0.0)) + (stencil . ,clarinet-lh-a-key-stencil) + (text? . ("A" . #f)) + (complexity . trill))) + (gis + . ((offset . (0.8 . 1.0)) + (stencil . ,clarinet-lh-gis-key-stencil) + (text? . ("G" . 1)) + (complexity . trill))) + (ees + . ((offset . (0.0 . 0.0)) + (stencil . ,clarinet-lh-ees-key-stencil) + (text? . ("E" . 0)) + (complexity . trill))) + (cis + . ((offset . (-0.85 . 0.2)) + (stencil . ,clarinet-lh-cis-key-stencil) + (text? . ("C" . 1)) + (complexity . trill))) + (f + . ((offset . (3.6 . 0.5)) + (stencil . ,clarinet-lh-f-key-stencil) + (text? . ("F" . #f)) + (complexity . trill))) + (e + . ((offset . (2.05 . -3.65)) + (stencil . ,clarinet-lh-e-key-stencil) + (text? . ("E" . #f)) + (complexity . trill))) + (fis + . ((offset . (2.25 . -4.15)) + (stencil . ,clarinet-lh-fis-key-stencil) + (text? . ("F" . 1)) + (complexity . trill)))) + (assoc-get 'left-extra-key-names change-points))) + (right-hand + . ,(append `((one + . ((offset . (0.0 . 0.75)) + (stencil . ,clarinet-rh-one-key-stencil) + (text? . "1") + (complexity . trill))) + (two + . ((offset . (0.0 . 0.25)) + (stencil . ,clarinet-rh-two-key-stencil) + (text? . "2") + (complexity . trill))) + (three + . ((offset . (0.0 . -0.25)) + (stencil . ,clarinet-rh-three-key-stencil) + (text? . "3") + (complexity . trill))) + (four + . ((offset . (0.0 . -0.75)) + (stencil . ,clarinet-rh-four-key-stencil) + (text? . "4") + (complexity . trill))) + (b + . ((offset . (0.0 . 0.0)) + (stencil . ,clarinet-rh-b-key-stencil) + (text? . ("B" . #f)) + (complexity . trill))) + (fis + . ((offset . (0.0 . ,(* 4 (+ 0.75 CL-RH-HAIR)))) + (stencil . ,clarinet-rh-fis-key-stencil) + (text? . ("F" . 1)) + (complexity . trill))) + (gis + . ((offset . (,(+ 1.5 CL-RH-HAIR) + . ,(* 3 (+ 0.75 CL-RH-HAIR)))) + (stencil . ,clarinet-rh-gis-key-stencil) + (text? . ("G" . 1)) + (complexity . trill))) + (e + . ((offset . (0.0 . ,(* 2 (+ 0.75 CL-RH-HAIR)))) + (stencil . ,clarinet-rh-e-key-stencil) + (text? . ("E" . #f)) + (complexity . trill))) + (f + . ((offset . (,(+ 1.5 CL-RH-HAIR) + . ,(* 1 (+ 0.75 CL-RH-HAIR)))) + (stencil . ,clarinet-rh-f-key-stencil) + (text? . ("F" . #f)) + (complexity . trill)))) + (assoc-get 'bottom-group-key-names change-points))))) + (graphical-commands + . ((stencil-alist + . ((stencils + . ,(append (assoc-get 'right-thumb-group change-points) + `(,(simple-stencil-alist '(hidden . midline) + '(0.0 . 3.75)) + ((stencils + . ,(make-central-column-hole-addresses + CENTRAL-COLUMN-HOLE-H-LIST)) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0))) + ((stencils + . ,(make-left-hand-key-addresses '(thumb R))) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (-2.5 . 6.5))) + ((stencils + . ((left-hand . a) (left-hand . gis))) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (0.0 . 7.5))) + ,(simple-stencil-alist '(left-hand . ees) + '(1.0 . 5.0)) + ((stencils + . ,(make-left-hand-key-addresses '(cis f e fis))) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (0.0 . 3.9))) + ((stencils + . ,(make-right-hand-key-addresses + '(one two three four))) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (-1.25 . 3.75))) + ,(simple-stencil-alist '(right-hand . b) + '(-1.0 . 1.5)) + ((stencils + . ,(assoc-get 'bottom-right-group-key-addresses + change-points)) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (-4.0 . -0.75)))))) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0)))) + (draw-instructions + . ,(append (assoc-get 'low-rich-draw-rules change-points) + `((,apply-group-draw-rule-series + ,(append (assoc-get 'low-key-group change-points) + `(((left-hand . a) (left-hand . gis)) + ,(make-right-hand-key-addresses '(one two three four)) - ,(assoc-get 'low-left-hand-key-addresses - change-points) - ,(assoc-get 'right-hand-key-addresses - change-points)))) - (,rich-group-draw-rule - ((left-hand . R)) - ((left-hand . thumb))) - (,group-automate-rule - ,(make-central-column-hole-addresses - CENTRAL-COLUMN-HOLE-LIST)) - (,group-automate-rule ((hidden . midline)))))) - (extra-offset-instructions - . ,(append (assoc-get 'low-extra-offset-rule change-points) - `((,rich-group-extra-offset-rule - ((central-column . h)) - ((central-column . one) - (left-hand . a) - (left-hand . gis)) - (0.0 . 0.8)) - (,uniform-extra-offset-rule (0.0 . 0.0))))))) - (text-commands - . ((stencil-alist - . ((stencils - . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) - ((stencils - . ,(make-central-column-hole-addresses + ,(assoc-get 'low-left-hand-key-addresses + change-points) + ,(assoc-get 'right-hand-key-addresses + change-points)))) + (,rich-group-draw-rule + ((left-hand . R)) + ((left-hand . thumb))) + (,group-automate-rule + ,(make-central-column-hole-addresses + CENTRAL-COLUMN-HOLE-LIST)) + (,group-automate-rule ((hidden . midline)))))) + (extra-offset-instructions + . ,(append (assoc-get 'low-extra-offset-rule change-points) + `((,rich-group-extra-offset-rule + ((central-column . h)) + ((central-column . one) + (left-hand . a) + (left-hand . gis)) + (0.0 . 0.8)) + (,uniform-extra-offset-rule (0.0 . 0.0))))))) + (text-commands + . ((stencil-alist + . ((stencils + . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) + ((stencils + . ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0))) - ((stencils . ((left-hand . thumb) (left-hand . R))) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (-2.5 . 6.5))) - ((stencils - . ,(assoc-get 'all-left-hand-key-addresses change-points)) - (textual? . ,lh-woodwind-text-stencil) - (offset . (1.5 . 3.75))) - ((stencils - . ,(make-right-hand-key-addresses '(one two three four))) - (textual? . ,number-column-stencil) - (offset . (-1.25 . 3.75))) - ((stencils . ,(assoc-get 'right-hand-key-addresses - change-points)) - (textual? . ,rh-woodwind-text-stencil) - (offset . (-1.25 . 0.0))))) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0)))) - (draw-instructions - . ((,apply-group-draw-rule-series - (,(assoc-get 'all-left-hand-key-addresses change-points) - ,(make-right-hand-key-addresses '(one two three four)) - ,(assoc-get 'right-hand-key-addresses change-points))) - (,group-automate-rule - ,(make-central-column-hole-addresses - CENTRAL-COLUMN-HOLE-LIST)) - (,group-automate-rule ((hidden . midline))))) - (extra-offset-instructions - . ((,rich-group-extra-offset-rule + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0))) + ((stencils . ((left-hand . thumb) (left-hand . R))) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (-2.5 . 6.5))) + ((stencils + . ,(assoc-get 'all-left-hand-key-addresses change-points)) + (textual? . ,lh-woodwind-text-stencil) + (offset . (1.5 . 3.75))) + ((stencils + . ,(make-right-hand-key-addresses '(one two three four))) + (textual? . ,number-column-stencil) + (offset . (-1.25 . 3.75))) + ((stencils . ,(assoc-get 'right-hand-key-addresses + change-points)) + (textual? . ,rh-woodwind-text-stencil) + (offset . (-1.25 . 0.0))))) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0)))) + (draw-instructions + . ((,apply-group-draw-rule-series + (,(assoc-get 'all-left-hand-key-addresses change-points) + ,(make-right-hand-key-addresses '(one two three four)) + ,(assoc-get 'right-hand-key-addresses change-points))) + (,group-automate-rule + ,(make-central-column-hole-addresses + CENTRAL-COLUMN-HOLE-LIST)) + (,group-automate-rule ((hidden . midline))))) + (extra-offset-instructions + . ((,rich-group-extra-offset-rule ((central-column . h)) ((central-column . one) (left-hand . a) (left-hand . gis)) (0.0 . 0.8)) - (,uniform-extra-offset-rule (0.0 . 0.0)))))))))) + (,uniform-extra-offset-rule (0.0 . 0.0)))))))))) ;; Saxophone assembly instructions @@ -1027,618 +1027,618 @@ (define saxophone-change-points ((make-named-spreadsheet '(saxophone baritone-saxophone)) - `((low-a-key-definition - . (() - ((low-a - . ((offset . (0.0 . 0.0)) - (stencil . ,saxophone-lh-low-a-key-stencil) - (text? . #f) - (complexity . trill)))))) + `((low-a-key-definition + . (() + ((low-a + . ((offset . (0.0 . 0.0)) + (stencil . ,saxophone-lh-low-a-key-stencil) + (text? . #f) + (complexity . trill)))))) (low-a-key-group - . (() - (,(simple-stencil-alist '(left-hand . low-a) '(-5.0 . 7.0))))) + . (() + (,(simple-stencil-alist '(left-hand . low-a) '(-5.0 . 7.0))))) (low-a-presence - . (() - ((left-hand . low-a)))) + . (() + ((left-hand . low-a)))) (left-hand-key-names - . (,(make-right-hand-key-addresses - '(ees d f front-f bes gis cis b low-bes)) - ,(make-right-hand-key-addresses - '(ees d f front-f bes gis cis b low-bes low-a))))))) + . (,(make-right-hand-key-addresses + '(ees d f front-f bes gis cis b low-bes)) + ,(make-right-hand-key-addresses + '(ees d f front-f bes gis cis b low-bes low-a))))))) (define (generate-saxophone-family-entry saxophone-name) (let* - ((change-points - (get-named-spreadsheet-column - (saxophone-name-passerelle saxophone-name) saxophone-change-points))) - `(,saxophone-name - . ((keys - . ((hidden - . ((midline - . ((offset . (0.0 . 0.0)) - (stencil . ,midline-stencil) - (text? . #f) - (complexity . basic))))) - (central-column - . ((one - . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . trill))) - (two - . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . trill))) - (three - . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . trill))) - (four - . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . trill))) - (five - . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . trill))) - (six - . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,column-circle-stencil) - (text? . #f) - (complexity . trill))))) - (left-hand - . ,(append (assoc-get 'low-a-key-definition change-points) - `((T - . ((offset . (0.0 . 0.0)) - (stencil . ,saxophone-lh-T-key-stencil) - (text? . ("T" . #f)) - (complexity . trill))) - (ees - . ((offset . (0.4 . 1.6)) - (stencil . ,saxophone-lh-ees-key-stencil) - (text? . ("E" . 0)) - (complexity . trill))) - (d - . ((offset . (1.5 . 0.5)) - (stencil . ,saxophone-lh-d-key-stencil) - (text? . ("D" . #f)) - (complexity . trill))) - (f - . ((offset . (0.0 . 0.0)) - (stencil . ,saxophone-lh-f-key-stencil) - (text? . ("F" . #f)) - (complexity . trill))) - (front-f - . ((offset . (0.0 . 0.0)) - (stencil . ,saxophone-lh-front-f-key-stencil) - (text? . ("f" . #f)) - (complexity . trill))) - (bes - . ((offset . (0.0 . 0.0)) - (stencil . ,saxophone-lh-bes-key-stencil) - (text? . ("B" . 0)) - (complexity . trill))) - (gis - . ((offset . (0.0 . 1.1)) - (stencil . ,saxophone-lh-gis-key-stencil) - (text? . ("G" . 1)) - (complexity . trill))) - (cis - . ((offset . (2.4 . 0.0)) - (stencil . ,saxophone-lh-cis-key-stencil) - (text? . ("C" . 1)) - (complexity . trill))) - (b - . ((offset . (0.0 . 0.0)) - (stencil . ,saxophone-lh-b-key-stencil) - (text? . ("B" . #f)) - (complexity . trill))) - (low-bes - . ((offset . (0.0 . -0.2)) - (stencil . ,saxophone-lh-low-bes-key-stencil) - (text? . ("b" . 0)) - (complexity . trill)))))) - (right-hand - . ((e - . ((offset . (0.0 . 2.0)) - (stencil . ,saxophone-rh-e-key-stencil) - (text? . ("E" . #f)) - (complexity . trill))) - (c - . ((offset . (0.0 . 0.9)) - (stencil . ,saxophone-rh-c-key-stencil) - (text? . ("C" . #f)) - (complexity . trill))) - (bes - . ((offset . (0.0 . 0.0)) - (stencil . ,saxophone-rh-bes-key-stencil) - (text? . ("B" . 0)) - (complexity . trill))) - (high-fis - . ((offset . (0.0 . 0.0)) - (stencil . ,saxophone-rh-high-fis-key-stencil) - (text? . ("hF" . 1)) - (complexity . trill))) - (fis - . ((offset . (0.0 . 0.0)) - (stencil . ,saxophone-rh-fis-key-stencil) - (text? . ("F" . 1)) - (complexity . trill))) - (ees - . ((offset . (0.0 . 0.7)) - (stencil . ,saxophone-rh-ees-key-stencil) - (text? . ("E" . 0)) - (complexity . trill))) - (low-c - . ((offset . (-1.2 . -0.1)) - (stencil . ,saxophone-rh-low-c-key-stencil) - (text? . ("c" . #f)) - (complexity . trill))))))) - (graphical-commands - . ((stencil-alist - . ((stencils - . ,(append (assoc-get 'low-a-key-group change-points) - `(,(simple-stencil-alist '(hidden . midline) - '(0.0 . 3.75)) - ((stencils - . ,(make-central-column-hole-addresses - CENTRAL-COLUMN-HOLE-LIST)) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0))) - ((stencils - . ,(make-left-hand-key-addresses '(ees d f))) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (1.5 . 6.8))) - ,(simple-stencil-alist '(left-hand . front-f) - '(0.0 . 7.35)) - ,(simple-stencil-alist '(left-hand . T) - '(-2.2 . 6.5)) - ,(simple-stencil-alist '(left-hand . bes) - '(0.0 . 6.2)) - ((stencils - . ,(make-left-hand-key-addresses - '(gis cis b low-bes))) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (1.2 . 3.5))) - ((stencils - . ,(make-right-hand-key-addresses '(e c bes))) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (-2.3 . 3.4))) - ,(simple-stencil-alist '(right-hand . high-fis) - '(-1.8 . 2.5)) - ,(simple-stencil-alist '(right-hand . fis) - '(-1.5 . 1.5)) - ((stencils - . ,(make-right-hand-key-addresses '(ees low-c))) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (-2.0 . 0.3)))))) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0)))) - (draw-instructions - . ((,apply-group-draw-rule-series - (,(make-left-hand-key-addresses '(ees d f)) - ,(make-left-hand-key-addresses '(gis cis b low-bes)) - ,(make-right-hand-key-addresses '(e c bes)) - ,(make-right-hand-key-addresses '(ees low-c)))) - (,group-automate-rule - ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) - (,group-automate-rule ((hidden . midline))))) - (extra-offset-instructions - . ((,rich-group-extra-offset-rule - ((left-hand . bes)) - ,(append (assoc-get 'low-a-presence change-points) - '((central-column . one) - (left-hand . front-f) - (left-hand . T) - (left-hand . ees) - (left-hand . d) - (left-hand . f))) - (0.0 . 1.0)) - (,uniform-extra-offset-rule (0.0 . 0.0)))))) - (text-commands - . ((stencil-alist - . ((stencils - . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) - ((stencils - . ,(make-central-column-hole-addresses - CENTRAL-COLUMN-HOLE-LIST)) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0))) - ,(simple-stencil-alist '(left-hand . T) '(-1.0 . 7.0)) - ((stencils - . ,(assoc-get 'left-hand-key-names change-points)) - (textual? . ,lh-woodwind-text-stencil) - (offset . (1.5 . 3.75))) - ((stencils - . ,(make-right-hand-key-addresses - '(e c bes high-fis fis ees low-c))) - (textual? . ,rh-woodwind-text-stencil) - (offset . (-1.25 . 0.0))))) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0)))) - (draw-instructions - . ((,apply-group-draw-rule-series - (,(make-left-hand-key-addresses - '(ees d f front-f bes gis cis b low-bes)) - ,(make-right-hand-key-addresses - '(e c bes high-fis fis ees low-c)))) - (,group-automate-rule - ,(make-central-column-hole-addresses + ((change-points + (get-named-spreadsheet-column + (saxophone-name-passerelle saxophone-name) saxophone-change-points))) + `(,saxophone-name + . ((keys + . ((hidden + . ((midline + . ((offset . (0.0 . 0.0)) + (stencil . ,midline-stencil) + (text? . #f) + (complexity . basic))))) + (central-column + . ((one + . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . trill))) + (two + . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . trill))) + (three + . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . trill))) + (four + . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . trill))) + (five + . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . trill))) + (six + . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,column-circle-stencil) + (text? . #f) + (complexity . trill))))) + (left-hand + . ,(append (assoc-get 'low-a-key-definition change-points) + `((T + . ((offset . (0.0 . 0.0)) + (stencil . ,saxophone-lh-T-key-stencil) + (text? . ("T" . #f)) + (complexity . trill))) + (ees + . ((offset . (0.4 . 1.6)) + (stencil . ,saxophone-lh-ees-key-stencil) + (text? . ("E" . 0)) + (complexity . trill))) + (d + . ((offset . (1.5 . 0.5)) + (stencil . ,saxophone-lh-d-key-stencil) + (text? . ("D" . #f)) + (complexity . trill))) + (f + . ((offset . (0.0 . 0.0)) + (stencil . ,saxophone-lh-f-key-stencil) + (text? . ("F" . #f)) + (complexity . trill))) + (front-f + . ((offset . (0.0 . 0.0)) + (stencil . ,saxophone-lh-front-f-key-stencil) + (text? . ("f" . #f)) + (complexity . trill))) + (bes + . ((offset . (0.0 . 0.0)) + (stencil . ,saxophone-lh-bes-key-stencil) + (text? . ("B" . 0)) + (complexity . trill))) + (gis + . ((offset . (0.0 . 1.1)) + (stencil . ,saxophone-lh-gis-key-stencil) + (text? . ("G" . 1)) + (complexity . trill))) + (cis + . ((offset . (2.4 . 0.0)) + (stencil . ,saxophone-lh-cis-key-stencil) + (text? . ("C" . 1)) + (complexity . trill))) + (b + . ((offset . (0.0 . 0.0)) + (stencil . ,saxophone-lh-b-key-stencil) + (text? . ("B" . #f)) + (complexity . trill))) + (low-bes + . ((offset . (0.0 . -0.2)) + (stencil . ,saxophone-lh-low-bes-key-stencil) + (text? . ("b" . 0)) + (complexity . trill)))))) + (right-hand + . ((e + . ((offset . (0.0 . 2.0)) + (stencil . ,saxophone-rh-e-key-stencil) + (text? . ("E" . #f)) + (complexity . trill))) + (c + . ((offset . (0.0 . 0.9)) + (stencil . ,saxophone-rh-c-key-stencil) + (text? . ("C" . #f)) + (complexity . trill))) + (bes + . ((offset . (0.0 . 0.0)) + (stencil . ,saxophone-rh-bes-key-stencil) + (text? . ("B" . 0)) + (complexity . trill))) + (high-fis + . ((offset . (0.0 . 0.0)) + (stencil . ,saxophone-rh-high-fis-key-stencil) + (text? . ("hF" . 1)) + (complexity . trill))) + (fis + . ((offset . (0.0 . 0.0)) + (stencil . ,saxophone-rh-fis-key-stencil) + (text? . ("F" . 1)) + (complexity . trill))) + (ees + . ((offset . (0.0 . 0.7)) + (stencil . ,saxophone-rh-ees-key-stencil) + (text? . ("E" . 0)) + (complexity . trill))) + (low-c + . ((offset . (-1.2 . -0.1)) + (stencil . ,saxophone-rh-low-c-key-stencil) + (text? . ("c" . #f)) + (complexity . trill))))))) + (graphical-commands + . ((stencil-alist + . ((stencils + . ,(append (assoc-get 'low-a-key-group change-points) + `(,(simple-stencil-alist '(hidden . midline) + '(0.0 . 3.75)) + ((stencils + . ,(make-central-column-hole-addresses + CENTRAL-COLUMN-HOLE-LIST)) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0))) + ((stencils + . ,(make-left-hand-key-addresses '(ees d f))) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (1.5 . 6.8))) + ,(simple-stencil-alist '(left-hand . front-f) + '(0.0 . 7.35)) + ,(simple-stencil-alist '(left-hand . T) + '(-2.2 . 6.5)) + ,(simple-stencil-alist '(left-hand . bes) + '(0.0 . 6.2)) + ((stencils + . ,(make-left-hand-key-addresses + '(gis cis b low-bes))) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (1.2 . 3.5))) + ((stencils + . ,(make-right-hand-key-addresses '(e c bes))) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (-2.3 . 3.4))) + ,(simple-stencil-alist '(right-hand . high-fis) + '(-1.8 . 2.5)) + ,(simple-stencil-alist '(right-hand . fis) + '(-1.5 . 1.5)) + ((stencils + . ,(make-right-hand-key-addresses '(ees low-c))) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (-2.0 . 0.3)))))) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0)))) + (draw-instructions + . ((,apply-group-draw-rule-series + (,(make-left-hand-key-addresses '(ees d f)) + ,(make-left-hand-key-addresses '(gis cis b low-bes)) + ,(make-right-hand-key-addresses '(e c bes)) + ,(make-right-hand-key-addresses '(ees low-c)))) + (,group-automate-rule + ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) + (,group-automate-rule ((hidden . midline))))) + (extra-offset-instructions + . ((,rich-group-extra-offset-rule + ((left-hand . bes)) + ,(append (assoc-get 'low-a-presence change-points) + '((central-column . one) + (left-hand . front-f) + (left-hand . T) + (left-hand . ees) + (left-hand . d) + (left-hand . f))) + (0.0 . 1.0)) + (,uniform-extra-offset-rule (0.0 . 0.0)))))) + (text-commands + . ((stencil-alist + . ((stencils + . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) + ((stencils + . ,(make-central-column-hole-addresses + CENTRAL-COLUMN-HOLE-LIST)) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0))) + ,(simple-stencil-alist '(left-hand . T) '(-1.0 . 7.0)) + ((stencils + . ,(assoc-get 'left-hand-key-names change-points)) + (textual? . ,lh-woodwind-text-stencil) + (offset . (1.5 . 3.75))) + ((stencils + . ,(make-right-hand-key-addresses + '(e c bes high-fis fis ees low-c))) + (textual? . ,rh-woodwind-text-stencil) + (offset . (-1.25 . 0.0))))) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0)))) + (draw-instructions + . ((,apply-group-draw-rule-series + (,(make-left-hand-key-addresses + '(ees d f front-f bes gis cis b low-bes)) + ,(make-right-hand-key-addresses + '(e c bes high-fis fis ees low-c)))) + (,group-automate-rule + ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) - (,group-automate-rule ((hidden . midline))))) - (extra-offset-instructions - . ((,uniform-extra-offset-rule (0.0 . 0.0)))))))))) + (,group-automate-rule ((hidden . midline))))) + (extra-offset-instructions + . ((,uniform-extra-offset-rule (0.0 . 0.0)))))))))) ;; Bassoon assembly instructions (define bassoon-change-points ((make-named-spreadsheet '(bassoon contrabassoon)) - `((left-hand-additional-keys . - (((a . - ((offset . (0.0 . -0.3)) - (stencil . ,bassoon-lh-a-flick-key-stencil) - (text? . ("A" . #f)) - (complexity . trill))) - (w . - ((offset . (0.0 . 0.0)) - (stencil . ,bassoon-lh-whisper-key-stencil) - (text? . ("w" . #f)) - (complexity . trill)))) - ())) - (right-hand-additional-keys . - (((cis . - ((offset . (0.0 . 0.0)) - (stencil . ,bassoon-rh-cis-key-stencil) - (text? . ("C" . 1)) - (complexity . trill))) - (thumb-gis . - ((offset . (0.0 . 0.0)) - (stencil . ,bassoon-rh-thumb-gis-key-stencil) - (text? . ("G" . 1)) - (complexity . trill)))) - ())) + `((left-hand-additional-keys . + (((a . + ((offset . (0.0 . -0.3)) + (stencil . ,bassoon-lh-a-flick-key-stencil) + (text? . ("A" . #f)) + (complexity . trill))) + (w . + ((offset . (0.0 . 0.0)) + (stencil . ,bassoon-lh-whisper-key-stencil) + (text? . ("w" . #f)) + (complexity . trill)))) + ())) + (right-hand-additional-keys . + (((cis . + ((offset . (0.0 . 0.0)) + (stencil . ,bassoon-rh-cis-key-stencil) + (text? . ("C" . 1)) + (complexity . trill))) + (thumb-gis . + ((offset . (0.0 . 0.0)) + (stencil . ,bassoon-rh-thumb-gis-key-stencil) + (text? . ("G" . 1)) + (complexity . trill)))) + ())) (left-hand-flick-group . - (((left-hand . d) (left-hand . c) (left-hand . a)) - ((left-hand . d) (left-hand . c)))) + (((left-hand . d) (left-hand . c) (left-hand . a)) + ((left-hand . d) (left-hand . c)))) (left-hand-thumb-group . - (((left-hand . w) (left-hand . thumb-cis)) - ((left-hand . thumb-cis)))) + (((left-hand . w) (left-hand . thumb-cis)) + ((left-hand . thumb-cis)))) (cis-offset-instruction . - (((,rich-group-extra-offset-rule - ((right-hand . cis)) - ,(append - '((hidden . midline) (hidden . long-midline)) - (make-central-column-hole-addresses '(three two one)) - (make-left-hand-key-addresses - '(low-b low-bes low-c low-d d a c w thumb-cis - high-ees high-e cis ees))) - (0.0 . 0.9))) - ())) + (((,rich-group-extra-offset-rule + ((right-hand . cis)) + ,(append + '((hidden . midline) (hidden . long-midline)) + (make-central-column-hole-addresses '(three two one)) + (make-left-hand-key-addresses + '(low-b low-bes low-c low-d d a c w thumb-cis + high-ees high-e cis ees))) + (0.0 . 0.9))) + ())) (right-hand-lower-thumb-group . - (((right-hand . thumb-gis) (right-hand . thumb-fis)) - ((right-hand . thumb-fis)))) + (((right-hand . thumb-gis) (right-hand . thumb-fis)) + ((right-hand . thumb-fis)))) (right-hand-cis-key . - ((,(simple-stencil-alist '(right-hand . cis) '(-2.3 . 3.22))) - ())) + ((,(simple-stencil-alist '(right-hand . cis) '(-2.3 . 3.22))) + ())) (back-left-hand-key-addresses . - ((low-b low-bes low-c low-d d a c w thumb-cis) - (low-b low-bes low-c low-d d c thumb-cis))) + ((low-b low-bes low-c low-d d a c w thumb-cis) + (low-b low-bes low-c low-d d c thumb-cis))) (front-right-hand-key-addresses . - ((cis bes fis f gis) (bes fis f gis))) + ((cis bes fis f gis) (bes fis f gis))) (back-right-hand-key-addresses . - ((thumb-bes thumb-gis thumb-e thumb-fis) - (thumb-bes thumb-e thumb-fis)))))) + ((thumb-bes thumb-gis thumb-e thumb-fis) + (thumb-bes thumb-e thumb-fis)))))) (define (generate-bassoon-family-entry bassoon-name) (let* - ((change-points - (get-named-spreadsheet-column bassoon-name bassoon-change-points))) - `(,bassoon-name - . ((keys - . ((hidden - . ((midline - . ((offset . (0.0 . 0.0)) - (stencil . ,midline-stencil) - (text? . #f) - (complexity . basic))) - (long-midline - . ((offset . (0.0 . 0.0)) - (stencil . ,long-midline-stencil) - (text? . #f) - (complexity . basic))))) - (central-column - . ((one - . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,bassoon-cc-one-key-stencil) - (text? . #f) - (complexity . trill))) - (two - . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))) - (three - . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))) - (four - . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))) - (five - . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))) - (six - . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS)) - (stencil . ,ring-column-circle-stencil) - (text? . #f) - (complexity . ring))))) - (left-hand - . ,(append (assoc-get 'left-hand-additional-keys - change-points) - `((high-e - . ((offset . (0.0 . 0.0)) - (stencil . ,bassoon-lh-he-key-stencil) - (text? . ("hE" . #f)) - (complexity . trill))) - (high-ees - . ((offset . (0.0 . 0.0)) - (stencil . ,bassoon-lh-hees-key-stencil) - (text? . ("hE" . 0)) - (complexity . trill))) - (ees - . ((offset . (-1.0 . 1.0)) - (stencil . ,bassoon-lh-ees-key-stencil) - (text? . ("E" . 0)) - (complexity . trill))) - (cis - . ((offset . (0.0 . 0.0)) - (stencil . ,bassoon-lh-cis-key-stencil) - (text? . ("C" . 1)) - (complexity . trill))) - (low-bes - . ((offset . (0.0 . 0.0)) - (stencil . ,bassoon-lh-lbes-key-stencil) - (text? . ("b" . 0)) - (complexity . trill))) - (low-b - . ((offset . (-1.0 . -0.7)) - (stencil . ,bassoon-lh-lb-key-stencil) - (text? . ("b" . #f)) - (complexity . trill))) - (low-c - . ((offset . (0.0 . 0.0)) - (stencil . ,bassoon-lh-lc-key-stencil) - (text? . ("c" . #f)) - (complexity . trill))) - (low-d - . ((offset . (0.0 . 0.0)) - (stencil . ,bassoon-lh-ld-key-stencil) - (text? . ("d" . #f)) - (complexity . trill))) - (d - . ((offset . (-1.5 . 2.0)) - (stencil . ,bassoon-lh-d-flick-key-stencil) - (text? . ("D" . #f)) - (complexity . trill))) - (c - . ((offset . (-0.8 . 1.1)) - (stencil . ,bassoon-lh-c-flick-key-stencil) - (text? . ("C" . #f)) - (complexity . trill))) - (thumb-cis - . ((offset . (2.0 . -1.0)) - (stencil . ,bassoon-lh-thumb-cis-key-stencil) - (text? . ("C" . 1)) - (complexity . trill)))))) - (right-hand - . ,(append (assoc-get 'right-hand-additional-keys - change-points) - `((bes - . ((offset . (0.0 . 0.8)) - (stencil . ,bassoon-rh-bes-key-stencil) - (text? . ("B" . 0)) - (complexity . trill))) - (f - . ((offset . (-2.2 . 4.35)) - (stencil . ,bassoon-rh-f-key-stencil) - (text? . ("F" . #f)) - (complexity . trill))) - (fis - . ((offset . (1.5 . 1.0)) - (stencil . ,bassoon-rh-fis-key-stencil) - (text? . ("F" . 1)) - (complexity . trill))) - (gis - . ((offset . (0.0 . -0.15)) - (stencil . ,bassoon-rh-gis-key-stencil) - (text? . ("G" . 1)) - (complexity . trill))) - (thumb-bes - . ((offset . (0.0 . 0.0)) - (stencil . ,bassoon-rh-thumb-bes-key-stencil) - (text? . ("B" . 0)) - (complexity . trill))) - (thumb-e - . ((offset . (1.75 . 0.4)) - (stencil . ,bassoon-rh-thumb-e-key-stencil) - (text? . ("E" . #f)) - (complexity . trill))) - (thumb-fis - . ((offset . (-1.0 . 1.6)) - (stencil . ,bassoon-rh-thumb-fis-key-stencil) - (text? . ("F" . 1)) - (complexity . trill)))))))) - (graphical-commands - . ((stencil-alist - . ((stencils - . ,(append (assoc-get 'right-hand-cis-key change-points) - `(,(simple-stencil-alist '(hidden . midline) - '(0.0 . 3.75)) - ,(simple-stencil-alist '(hidden . long-midline) - '(0.0 . 3.80)) - ((stencils - . ,(make-central-column-hole-addresses + ((change-points + (get-named-spreadsheet-column bassoon-name bassoon-change-points))) + `(,bassoon-name + . ((keys + . ((hidden + . ((midline + . ((offset . (0.0 . 0.0)) + (stencil . ,midline-stencil) + (text? . #f) + (complexity . basic))) + (long-midline + . ((offset . (0.0 . 0.0)) + (stencil . ,long-midline-stencil) + (text? . #f) + (complexity . basic))))) + (central-column + . ((one + . ((offset . ,(assoc-get 'one CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,bassoon-cc-one-key-stencil) + (text? . #f) + (complexity . trill))) + (two + . ((offset . ,(assoc-get 'two CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))) + (three + . ((offset . ,(assoc-get 'three CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))) + (four + . ((offset . ,(assoc-get 'four CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))) + (five + . ((offset . ,(assoc-get 'five CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))) + (six + . ((offset . ,(assoc-get 'six CENTRAL-COLUMN-HOLE-PLACEMENTS)) + (stencil . ,ring-column-circle-stencil) + (text? . #f) + (complexity . ring))))) + (left-hand + . ,(append (assoc-get 'left-hand-additional-keys + change-points) + `((high-e + . ((offset . (0.0 . 0.0)) + (stencil . ,bassoon-lh-he-key-stencil) + (text? . ("hE" . #f)) + (complexity . trill))) + (high-ees + . ((offset . (0.0 . 0.0)) + (stencil . ,bassoon-lh-hees-key-stencil) + (text? . ("hE" . 0)) + (complexity . trill))) + (ees + . ((offset . (-1.0 . 1.0)) + (stencil . ,bassoon-lh-ees-key-stencil) + (text? . ("E" . 0)) + (complexity . trill))) + (cis + . ((offset . (0.0 . 0.0)) + (stencil . ,bassoon-lh-cis-key-stencil) + (text? . ("C" . 1)) + (complexity . trill))) + (low-bes + . ((offset . (0.0 . 0.0)) + (stencil . ,bassoon-lh-lbes-key-stencil) + (text? . ("b" . 0)) + (complexity . trill))) + (low-b + . ((offset . (-1.0 . -0.7)) + (stencil . ,bassoon-lh-lb-key-stencil) + (text? . ("b" . #f)) + (complexity . trill))) + (low-c + . ((offset . (0.0 . 0.0)) + (stencil . ,bassoon-lh-lc-key-stencil) + (text? . ("c" . #f)) + (complexity . trill))) + (low-d + . ((offset . (0.0 . 0.0)) + (stencil . ,bassoon-lh-ld-key-stencil) + (text? . ("d" . #f)) + (complexity . trill))) + (d + . ((offset . (-1.5 . 2.0)) + (stencil . ,bassoon-lh-d-flick-key-stencil) + (text? . ("D" . #f)) + (complexity . trill))) + (c + . ((offset . (-0.8 . 1.1)) + (stencil . ,bassoon-lh-c-flick-key-stencil) + (text? . ("C" . #f)) + (complexity . trill))) + (thumb-cis + . ((offset . (2.0 . -1.0)) + (stencil . ,bassoon-lh-thumb-cis-key-stencil) + (text? . ("C" . 1)) + (complexity . trill)))))) + (right-hand + . ,(append (assoc-get 'right-hand-additional-keys + change-points) + `((bes + . ((offset . (0.0 . 0.8)) + (stencil . ,bassoon-rh-bes-key-stencil) + (text? . ("B" . 0)) + (complexity . trill))) + (f + . ((offset . (-2.2 . 4.35)) + (stencil . ,bassoon-rh-f-key-stencil) + (text? . ("F" . #f)) + (complexity . trill))) + (fis + . ((offset . (1.5 . 1.0)) + (stencil . ,bassoon-rh-fis-key-stencil) + (text? . ("F" . 1)) + (complexity . trill))) + (gis + . ((offset . (0.0 . -0.15)) + (stencil . ,bassoon-rh-gis-key-stencil) + (text? . ("G" . 1)) + (complexity . trill))) + (thumb-bes + . ((offset . (0.0 . 0.0)) + (stencil . ,bassoon-rh-thumb-bes-key-stencil) + (text? . ("B" . 0)) + (complexity . trill))) + (thumb-e + . ((offset . (1.75 . 0.4)) + (stencil . ,bassoon-rh-thumb-e-key-stencil) + (text? . ("E" . #f)) + (complexity . trill))) + (thumb-fis + . ((offset . (-1.0 . 1.6)) + (stencil . ,bassoon-rh-thumb-fis-key-stencil) + (text? . ("F" . 1)) + (complexity . trill)))))))) + (graphical-commands + . ((stencil-alist + . ((stencils + . ,(append (assoc-get 'right-hand-cis-key change-points) + `(,(simple-stencil-alist '(hidden . midline) + '(0.0 . 3.75)) + ,(simple-stencil-alist '(hidden . long-midline) + '(0.0 . 3.80)) + ((stencils + . ,(make-central-column-hole-addresses CENTRAL-COLUMN-HOLE-LIST)) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0))) - ,(simple-stencil-alist '(left-hand . high-e) - '(-1.0 . 7.0)) - ,(simple-stencil-alist '(left-hand . high-ees) - '(-1.0 . 6.0)) - ((stencils - . ((left-hand . ees) (left-hand . cis))) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (3.0 . 3.75))) - ((stencils - . (((stencils - . ((left-hand . low-b) - (left-hand . low-bes))) - (xy-scale-function - . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (-2.0 . 9.0))) - ((stencils - . ,(assoc-get 'left-hand-flick-group - change-points)) - (xy-scale-function - . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (3.0 . 7.0))) - ,(simple-stencil-alist '(left-hand . low-c) - '(-1.0 . 4.5)) - ,(simple-stencil-alist '(left-hand . low-d) - '(-1.0 . 0.1)) - ((stencils - . ,(assoc-get 'left-hand-thumb-group - change-points)) - (xy-scale-function - . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (1.5 . -0.6))))) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (-5.5 . 4.7))) - ,(simple-stencil-alist '(right-hand . bes) - '(1.0 . 1.2)) - ((stencils - . ,(make-right-hand-key-addresses '(gis f fis))) - (xy-scale-function . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (2.0 . -1.25))) - ((stencils - . (((stencils - . ((right-hand . thumb-bes) - (right-hand . thumb-e))) - (xy-scale-function - . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (-1.22 . 5.25))) - ((stencils - . ,(assoc-get 'right-hand-lower-thumb-group - change-points)) - (xy-scale-function - . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (0.0 . 0.0))))) - (xy-scale-function - . (,return-1 . ,return-1)) - (textual? . #f) - (offset . (-5.0 . 0.0)))))) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0)))) - (draw-instructions - . ((,apply-group-draw-rule-series - (,(make-left-hand-key-addresses '(ees cis)) - ,(make-left-hand-key-addresses - (assoc-get 'back-left-hand-key-addresses change-points)) - ,(make-right-hand-key-addresses '(f fis gis)) - ,(make-right-hand-key-addresses - (assoc-get 'back-right-hand-key-addresses change-points)))) - (,group-automate-rule - ,(make-central-column-hole-addresses - CENTRAL-COLUMN-HOLE-LIST)) - (,bassoon-midline-rule + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0))) + ,(simple-stencil-alist '(left-hand . high-e) + '(-1.0 . 7.0)) + ,(simple-stencil-alist '(left-hand . high-ees) + '(-1.0 . 6.0)) + ((stencils + . ((left-hand . ees) (left-hand . cis))) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (3.0 . 3.75))) + ((stencils + . (((stencils + . ((left-hand . low-b) + (left-hand . low-bes))) + (xy-scale-function + . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (-2.0 . 9.0))) + ((stencils + . ,(assoc-get 'left-hand-flick-group + change-points)) + (xy-scale-function + . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (3.0 . 7.0))) + ,(simple-stencil-alist '(left-hand . low-c) + '(-1.0 . 4.5)) + ,(simple-stencil-alist '(left-hand . low-d) + '(-1.0 . 0.1)) + ((stencils + . ,(assoc-get 'left-hand-thumb-group + change-points)) + (xy-scale-function + . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (1.5 . -0.6))))) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (-5.5 . 4.7))) + ,(simple-stencil-alist '(right-hand . bes) + '(1.0 . 1.2)) + ((stencils + . ,(make-right-hand-key-addresses '(gis f fis))) + (xy-scale-function . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (2.0 . -1.25))) + ((stencils + . (((stencils + . ((right-hand . thumb-bes) + (right-hand . thumb-e))) + (xy-scale-function + . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (-1.22 . 5.25))) + ((stencils + . ,(assoc-get 'right-hand-lower-thumb-group + change-points)) + (xy-scale-function + . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (0.0 . 0.0))))) + (xy-scale-function + . (,return-1 . ,return-1)) + (textual? . #f) + (offset . (-5.0 . 0.0)))))) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0)))) + (draw-instructions + . ((,apply-group-draw-rule-series + (,(make-left-hand-key-addresses '(ees cis)) + ,(make-left-hand-key-addresses + (assoc-get 'back-left-hand-key-addresses change-points)) + ,(make-right-hand-key-addresses '(f fis gis)) + ,(make-right-hand-key-addresses + (assoc-get 'back-right-hand-key-addresses change-points)))) + (,group-automate-rule + ,(make-central-column-hole-addresses + CENTRAL-COLUMN-HOLE-LIST)) + (,bassoon-midline-rule ,(append - (make-left-hand-key-addresses - (assoc-get 'back-left-hand-key-addresses change-points)) - (make-right-hand-key-addresses - (assoc-get 'back-right-hand-key-addresses - change-points)))))) - (extra-offset-instructions - . ,(append - (assoc-get 'cis-offset-instruction change-points) - `((,uniform-extra-offset-rule (0.0 . 0.0))))))) - (text-commands - . ((stencil-alist - . ((stencils - . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) - ((stencils - . ,(make-central-column-hole-addresses - CENTRAL-COLUMN-HOLE-LIST)) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0))) - ((stencils - . ,(make-left-hand-key-addresses + (make-left-hand-key-addresses + (assoc-get 'back-left-hand-key-addresses change-points)) + (make-right-hand-key-addresses + (assoc-get 'back-right-hand-key-addresses + change-points)))))) + (extra-offset-instructions + . ,(append + (assoc-get 'cis-offset-instruction change-points) + `((,uniform-extra-offset-rule (0.0 . 0.0))))))) + (text-commands + . ((stencil-alist + . ((stencils + . (,(simple-stencil-alist '(hidden . midline) '(0.0 . 3.75)) + ((stencils + . ,(make-central-column-hole-addresses + CENTRAL-COLUMN-HOLE-LIST)) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0))) + ((stencils + . ,(make-left-hand-key-addresses '(high-e high-ees ees cis))) - (textual? . ,lh-woodwind-text-stencil) - (offset . (1.5 . 3.75))) - ((stencils - . ,(make-left-hand-key-addresses - (assoc-get 'back-left-hand-key-addresses - change-points))) - (textual? . ,rh-woodwind-text-stencil) - (offset . (-1.25 . 3.75))) - ((stencils - . ,(make-right-hand-key-addresses - (assoc-get 'front-right-hand-key-addresses - change-points))) - (textual? . ,lh-woodwind-text-stencil) - (offset . (1.5 . 0.0))) - ((stencils . - ,(make-right-hand-key-addresses - (assoc-get 'back-right-hand-key-addresses - change-points))) - (textual? . ,rh-woodwind-text-stencil) - (offset . (-1.25 . 0.0))))) - (xy-scale-function . (,identity . ,identity)) - (textual? . #f) - (offset . (0.0 . 0.0)))) - (draw-instructions - . ((,apply-group-draw-rule-series - (,(make-left-hand-key-addresses + (textual? . ,lh-woodwind-text-stencil) + (offset . (1.5 . 3.75))) + ((stencils + . ,(make-left-hand-key-addresses + (assoc-get 'back-left-hand-key-addresses + change-points))) + (textual? . ,rh-woodwind-text-stencil) + (offset . (-1.25 . 3.75))) + ((stencils + . ,(make-right-hand-key-addresses + (assoc-get 'front-right-hand-key-addresses + change-points))) + (textual? . ,lh-woodwind-text-stencil) + (offset . (1.5 . 0.0))) + ((stencils . + ,(make-right-hand-key-addresses + (assoc-get 'back-right-hand-key-addresses + change-points))) + (textual? . ,rh-woodwind-text-stencil) + (offset . (-1.25 . 0.0))))) + (xy-scale-function . (,identity . ,identity)) + (textual? . #f) + (offset . (0.0 . 0.0)))) + (draw-instructions + . ((,apply-group-draw-rule-series + (,(make-left-hand-key-addresses (assoc-get 'back-left-hand-key-addresses change-points)) - ,(make-right-hand-key-addresses + ,(make-right-hand-key-addresses (assoc-get 'front-right-hand-key-addresses change-points)) - ,(make-right-hand-key-addresses - (assoc-get 'back-right-hand-key-addresses change-points)) - ,(make-left-hand-key-addresses '(high-e high-ees ees cis)))) - (,group-automate-rule - ,(make-central-column-hole-addresses - CENTRAL-COLUMN-HOLE-LIST)) - (,group-automate-rule ((hidden . midline))))) - (extra-offset-instructions - . ((,uniform-extra-offset-rule (0.0 . 0.0)))))))))) + ,(make-right-hand-key-addresses + (assoc-get 'back-right-hand-key-addresses change-points)) + ,(make-left-hand-key-addresses '(high-e high-ees ees cis)))) + (,group-automate-rule + ,(make-central-column-hole-addresses + CENTRAL-COLUMN-HOLE-LIST)) + (,group-automate-rule ((hidden . midline))))) + (extra-offset-instructions + . ((,uniform-extra-offset-rule (0.0 . 0.0)))))))))) ;; Assembly functions @@ -1650,60 +1650,60 @@ (define (translate-key-instruction key-instruction) (let* - ((key-name (car key-instruction)) - (key-complexity (assoc-get 'complexity (cdr key-instruction)))) - (cond - ((eqv? key-complexity 'basic) + ((key-name (car key-instruction)) + (key-complexity (assoc-get 'complexity (cdr key-instruction)))) + (cond + ((eqv? key-complexity 'basic) `((,key-name . ,(assoc-get 'F HOLE-FILL-LIST)))) - ((eqv? key-complexity 'trill) - (make-symbol-alist key-name #t #f)) - ((eqv? key-complexity 'covered) - (make-symbol-alist key-name #f #f)) - ((eqv? key-complexity 'ring) - (make-symbol-alist key-name #f #t))))) + ((eqv? key-complexity 'trill) + (make-symbol-alist key-name #t #f)) + ((eqv? key-complexity 'covered) + (make-symbol-alist key-name #f #f)) + ((eqv? key-complexity 'ring) + (make-symbol-alist key-name #f #t))))) (define (update-possb-list input-key possibility-list canonic-list) (if (null? possibility-list) - (ly:error "woodwind markup error - invalid key or hole requested") - (if - (assoc-get input-key (cdar possibility-list)) - (append + (ly:error "woodwind markup error - invalid key or hole requested") + (if + (assoc-get input-key (cdar possibility-list)) + (append `(((,(caaar possibility-list) . ,(assoc-get input-key (cdar possibility-list))) . - ,(assoc-get (caar possibility-list) canonic-list))) - (assoc-remove (caar possibility-list) canonic-list)) - (update-possb-list input-key (cdr possibility-list) canonic-list)))) + ,(assoc-get (caar possibility-list) canonic-list))) + (assoc-remove (caar possibility-list) canonic-list)) + (update-possb-list input-key (cdr possibility-list) canonic-list)))) (define (key-crawler input-list possibility-list) (if (null? input-list) - (map car possibility-list) - (key-crawler - (cdr input-list) - (update-possb-list + (map car possibility-list) + (key-crawler + (cdr input-list) + (update-possb-list (car input-list) possibility-list possibility-list)))) (define (translate-draw-instructions input-alist key-name-alist) (apply append - (map (lambda (short long) - (let* - ((key-instructions - (map (lambda (instr) - `(((,long . ,(car instr)) . 0) - . ,(translate-key-instruction instr))) - (assoc-get long key-name-alist)))) - (key-crawler (assoc-get short input-alist) key-instructions))) - '(hd cc lh rh) - '(hidden central-column left-hand right-hand)))) + (map (lambda (short long) + (let* + ((key-instructions + (map (lambda (instr) + `(((,long . ,(car instr)) . 0) + . ,(translate-key-instruction instr))) + (assoc-get long key-name-alist)))) + (key-crawler (assoc-get short input-alist) key-instructions))) + '(hd cc lh rh) + '(hidden central-column left-hand right-hand)))) (define (uniform-draw-instructions key-name-alist) - (apply append - (map (lambda (long) - (map (lambda (key-instructions) - `((,long . ,(car key-instructions)) . 1)) - (assoc-get long key-name-alist))) - '(hidden central-column left-hand right-hand)))) + (apply append + (map (lambda (long) + (map (lambda (key-instructions) + `((,long . ,(car key-instructions)) . 1)) + (assoc-get long key-name-alist))) + '(hidden central-column left-hand right-hand)))) (define (list-all-possible-keys key-name-alist) (map (lambda (short long) @@ -1756,94 +1756,94 @@ (define (assemble-stencils - stencil-alist - key-bank - draw-instructions - extra-offset-instructions - radius - thick - xy-stretch - layout - props) + stencil-alist + key-bank + draw-instructions + extra-offset-instructions + radius + thick + xy-stretch + layout + props) (apply - ly:stencil-add - (map (lambda (node) - (ly:stencil-translate - (if (pair? (cdr node)) - (if (assoc-get 'textual? node) - ((assoc-get 'textual? node) (map (lambda (key) - (assoc-get 'text? key)) - (map (lambda (instr) - (get-key - instr - key-bank)) - (assoc-get 'stencils node))) - radius - (map (lambda (key) - (assoc-get - key - draw-instructions)) - (assoc-get 'stencils - node)) - layout - props) - (assemble-stencils - node - key-bank - draw-instructions - extra-offset-instructions - radius - thick - (coord-apply (assoc-get 'xy-scale-function stencil-alist) - xy-stretch) - layout - props)) + ly:stencil-add + (map (lambda (node) + (ly:stencil-translate + (if (pair? (cdr node)) + (if (assoc-get 'textual? node) + ((assoc-get 'textual? node) (map (lambda (key) + (assoc-get 'text? key)) + (map (lambda (instr) + (get-key + instr + key-bank)) + (assoc-get 'stencils node))) + radius + (map (lambda (key) + (assoc-get + key + draw-instructions)) + (assoc-get 'stencils + node)) + layout + props) + (assemble-stencils + node + key-bank + draw-instructions + extra-offset-instructions + radius + thick + (coord-apply (assoc-get 'xy-scale-function stencil-alist) + xy-stretch) + layout + props)) (if (= 0 (assoc-get node draw-instructions)) empty-stencil ((assoc-get 'stencil (get-key node key-bank)) - radius - thick - (assoc-get node draw-instructions) - layout - props))) + radius + thick + (assoc-get node draw-instructions) + layout + props))) + (coord-scale + (coord-translate (coord-scale - (coord-translate - (coord-scale - (assoc-get - 'offset - (if (pair? (cdr node)) - node - (get-key node key-bank))) - (coord-apply - (assoc-get 'xy-scale-function stencil-alist) - xy-stretch)) - (if - (assoc-get node extra-offset-instructions) - (assoc-get node extra-offset-instructions) - '(0.0 . 0.0))) - radius))) - (assoc-get 'stencils stencil-alist)))) + (assoc-get + 'offset + (if (pair? (cdr node)) + node + (get-key node key-bank))) + (coord-apply + (assoc-get 'xy-scale-function stencil-alist) + xy-stretch)) + (if + (assoc-get node extra-offset-instructions) + (assoc-get node extra-offset-instructions) + '(0.0 . 0.0))) + radius))) + (assoc-get 'stencils stencil-alist)))) (define*-public (print-keys instrument #:optional (port (current-output-port))) (format port "\nPrinting keys for: ~a\n" instrument) (let ((chosen-instrument (assoc-get instrument woodwind-data-alist))) - (do ((key-list - (list-all-possible-keys (assoc-get 'keys chosen-instrument)) - (cdr key-list))) - ((null? key-list)) + (do ((key-list + (list-all-possible-keys (assoc-get 'keys chosen-instrument)) + (cdr key-list))) + ((null? key-list)) (format port "~a\n ~a\n" (caar key-list) (cdar key-list))))) (define-public (get-woodwind-key-list instrument) (list-all-possible-keys-verbose - (assoc-get - 'keys - (assoc-get instrument woodwind-data-alist)))) + (assoc-get + 'keys + (assoc-get instrument woodwind-data-alist)))) (define*-public (print-keys-verbose instrument - #:optional (port (current-output-port))) + #:optional (port (current-output-port))) (format port "\nPrinting keys in verbose mode for: ~a\n" instrument) (do ((key-list (get-woodwind-key-list instrument) - (cdr key-list))) + (cdr key-list))) ((null? key-list)) (format port "~a\n" (caar key-list)) (for-each @@ -1945,35 +1945,35 @@ a diagram with all of the keys drawn but none filled, for example: (xy-stretch `(1.0 . 2.5)) (chosen-instrument (assoc-get instrument woodwind-data-alist)) (chosen-instrument - (if (not chosen-instrument) - (ly:error "~a is not a valid woodwind instrument." - instrument) - chosen-instrument)) + (if (not chosen-instrument) + (ly:error "~a is not a valid woodwind instrument." + instrument) + chosen-instrument)) (stencil-info - (assoc-get - (if display-graphic 'graphical-commands 'text-commands) - chosen-instrument)) + (assoc-get + (if display-graphic 'graphical-commands 'text-commands) + chosen-instrument)) (pressed-info - (if (null? user-draw-commands) - (uniform-draw-instructions (assoc-get 'keys chosen-instrument)) - (translate-draw-instructions - (append '((hd . ())) user-draw-commands) - (assoc-get 'keys chosen-instrument)))) + (if (null? user-draw-commands) + (uniform-draw-instructions (assoc-get 'keys chosen-instrument)) + (translate-draw-instructions + (append '((hd . ())) user-draw-commands) + (assoc-get 'keys chosen-instrument)))) (draw-info - (function-chain - pressed-info - (assoc-get 'draw-instructions stencil-info))) + (function-chain + pressed-info + (assoc-get 'draw-instructions stencil-info))) (extra-offset-info - (function-chain - pressed-info - (assoc-get 'extra-offset-instructions stencil-info)))) + (function-chain + pressed-info + (assoc-get 'extra-offset-instructions stencil-info)))) (assemble-stencils - (assoc-get 'stencil-alist stencil-info) - (assoc-get 'keys chosen-instrument) - draw-info - extra-offset-info - radius - thick - xy-stretch - layout - props))) + (assoc-get 'stencil-alist stencil-info) + (assoc-get 'keys chosen-instrument) + draw-info + extra-offset-info + radius + thick + xy-stretch + layout + props))) diff --git a/scm/document-backend.scm b/scm/document-backend.scm index 71ba5a274f..a4c25cfe3c 100644 --- a/scm/document-backend.scm +++ b/scm/document-backend.scm @@ -25,95 +25,95 @@ ;; properly sort all grobs, properties, and interfaces ;; within the all-grob-descriptions alist (map - (lambda (x) - (let* ((props (assoc-ref all-grob-descriptions (car x))) - (meta (assoc-ref props 'meta)) - (interfaces (assoc-ref meta 'interfaces))) - (set! all-grob-descriptions - (sort (assoc-set! all-grob-descriptions (car x) - (sort-grob-properties - (assoc-set! props 'meta - (assoc-set! meta 'interfaces - (sort interfaces ly:symbol-ci<?))))) - ly:alist-ci<?)))) - all-grob-descriptions) + (lambda (x) + (let* ((props (assoc-ref all-grob-descriptions (car x))) + (meta (assoc-ref props 'meta)) + (interfaces (assoc-ref meta 'interfaces))) + (set! all-grob-descriptions + (sort (assoc-set! all-grob-descriptions (car x) + (sort-grob-properties + (assoc-set! props 'meta + (assoc-set! meta 'interfaces + (sort interfaces ly:symbol-ci<?))))) + ly:alist-ci<?)))) + all-grob-descriptions) (define (interface-doc-string interface grob-description) (let* ((name (car interface)) - (desc (cadr interface)) - (props (caddr interface)) - (docfunc (lambda (pr) - (property->texi - 'backend pr grob-description))) - (iprops (filter (lambda (x) (object-property x 'backend-internal)) - props)) - (uprops (filter - (lambda (x) (not (object-property x 'backend-internal))) - props)) - (user-propdocs (map docfunc uprops)) - (internal-propdocs (map docfunc iprops))) + (desc (cadr interface)) + (props (caddr interface)) + (docfunc (lambda (pr) + (property->texi + 'backend pr grob-description))) + (iprops (filter (lambda (x) (object-property x 'backend-internal)) + props)) + (uprops (filter + (lambda (x) (not (object-property x 'backend-internal))) + props)) + (user-propdocs (map docfunc uprops)) + (internal-propdocs (map docfunc iprops))) (string-append desc (if (pair? uprops) - (string-append - "\n\n@subsubheading User settable properties:\n" - (description-list->texi user-propdocs #t)) - "") + (string-append + "\n\n@subsubheading User settable properties:\n" + (description-list->texi user-propdocs #t)) + "") (if (pair? iprops) - (string-append - "\n\n@subsubheading Internal properties:\n" - (description-list->texi internal-propdocs #t)) - "")))) + (string-append + "\n\n@subsubheading Internal properties:\n" + (description-list->texi internal-propdocs #t)) + "")))) (define iface->grob-table (make-hash-table 61)) ;; extract ifaces, and put grob into the hash table. (map (lambda (x) (let* ((meta (assoc-get 'meta (cdr x))) - (ifaces (assoc-get 'interfaces meta))) + (ifaces (assoc-get 'interfaces meta))) (map (lambda (iface) - (hashq-set! - iface->grob-table iface - (cons (car x) - (hashq-ref iface->grob-table iface '())))) - ifaces))) + (hashq-set! + iface->grob-table iface + (cons (car x) + (hashq-ref iface->grob-table iface '())))) + ifaces))) all-grob-descriptions) ;; First level Interface description (define (interface-doc interface) (let* ((name (symbol->string (car interface))) - (interface-list (human-listify - (map ref-ify - (sort - (map symbol->string - (hashq-ref iface->grob-table - (car interface) - '())) - ly:string-ci<?))))) + (interface-list (human-listify + (map ref-ify + (sort + (map symbol->string + (hashq-ref iface->grob-table + (car interface) + '())) + ly:string-ci<?))))) (make <texi-node> #:name name #:text (string-append - (interface-doc-string (cdr interface) '()) - "\n\n" - "This grob interface " - (if (equal? interface-list "none") - "is not used in any graphical object" - (string-append - "is used in the following graphical object(s): " - interface-list)) - ".")))) + (interface-doc-string (cdr interface) '()) + "\n\n" + "This grob interface " + (if (equal? interface-list "none") + "is not used in any graphical object" + (string-append + "is used in the following graphical object(s): " + interface-list)) + ".")))) (define (grob-alist->texi alist) (let* ((uprops (filter (lambda (x) (not (object-property x 'backend-internal))) - (map car alist)))) + (map car alist)))) (description-list->texi (map (lambda (y) (property->texi 'backend y alist)) - uprops) + uprops) #t))) (define (grob-doc description) @@ -121,26 +121,26 @@ node." (let* ((meta (assoc-get 'meta description)) - (name (assoc-get 'name meta)) - ;; (bla (display name)) - (ifaces (map lookup-interface (assoc-get 'interfaces meta))) - (ifacedoc (map ref-ify - (sort - (map (lambda (iface) - (if (pair? iface) - (symbol->string (car iface)) - (ly:error (_ "pair expected in doc ~s") name))) - ifaces) - ly:string-ci<?))) - (engravers (filter - (lambda (x) (engraver-makes-grob? name x)) - all-engravers-list)) - (namestr (symbol->string name)) - (engraver-names (map symbol->string - (map ly:translator-name engravers))) - (engraver-list (human-listify - (map ref-ify - (map engraver-name engraver-names))))) + (name (assoc-get 'name meta)) + ;; (bla (display name)) + (ifaces (map lookup-interface (assoc-get 'interfaces meta))) + (ifacedoc (map ref-ify + (sort + (map (lambda (iface) + (if (pair? iface) + (symbol->string (car iface)) + (ly:error (_ "pair expected in doc ~s") name))) + ifaces) + ly:string-ci<?))) + (engravers (filter + (lambda (x) (engraver-makes-grob? name x)) + all-engravers-list)) + (namestr (symbol->string name)) + (engraver-names (map symbol->string + (map ly:translator-name engravers))) + (engraver-list (human-listify + (map ref-ify + (map engraver-name engraver-names))))) (make <texi-node> #:name namestr @@ -148,10 +148,10 @@ node." (string-append namestr " objects " (if (equal? engraver-list "none") - "are not created by any engraver" - (string-append - "are created by: " - engraver-list)) + "are not created by any engraver" + (string-append + "are created by: " + engraver-list)) "." "\n\nStandard settings:\n\n" @@ -174,7 +174,7 @@ node." '() (ly:all-grob-interfaces))) (set! interface-description-alist - (sort interface-description-alist ly:alist-ci<?)) + (sort interface-description-alist ly:alist-ci<?)) ;;;;;;;;;; check for dangling backend properties. (define (mark-interface-properties entry) @@ -186,7 +186,7 @@ node." (define (check-dangling-properties prop) (if (not (object-property prop 'iface-marked)) (ly:error (string-append "define-grob-properties.scm: " - (_ "cannot find interface for property: ~S")) prop))) + (_ "cannot find interface for property: ~S")) prop))) (map check-dangling-properties all-backend-properties) @@ -195,8 +195,8 @@ node." (define (lookup-interface name) (let* ((entry (hashq-ref (ly:all-grob-interfaces) name #f))) (if entry - entry - (ly:error (_ "unknown Grob interface: ~S") name)))) + entry + (ly:error (_ "unknown Grob interface: ~S") name)))) (define (all-interfaces-doc) (make <texi-node> @@ -207,9 +207,9 @@ node." (define (backend-properties-doc-string lst) (let* ((ps (sort (map symbol->string lst) ly:string-ci<?)) - (descs (map (lambda (prop) - (property->texi 'backend (string->symbol prop) '())) ps)) - (texi (description-list->texi descs #f))) + (descs (map (lambda (prop) + (property->texi 'backend (string->symbol prop) '())) ps)) + (texi (description-list->texi descs #f))) texi)) ;;(dump-node (grob-doc (cdadr all-grob-descriptions)) (current-output-port) 0 ) diff --git a/scm/document-context-mods.scm b/scm/document-context-mods.scm index d115389a1f..fc3c4ad28a 100644 --- a/scm/document-context-mods.scm +++ b/scm/document-context-mods.scm @@ -73,8 +73,8 @@ " name-sym name-sym - (if (pair? docstring) - (cadar docstring) + (if (pair? docstring) + (cadar docstring) (begin (ly:warning "context modification `~a' not documented." name-sym) "(undocumented; fixme)")) diff --git a/scm/document-functions.scm b/scm/document-functions.scm index 1fdabaeacf..282bf24044 100644 --- a/scm/document-functions.scm +++ b/scm/document-functions.scm @@ -20,13 +20,13 @@ (ice-9 regex)) (define (dashify-underscores str) - (regexp-substitute/global #f "_" str 'pre "-" 'post)) + (regexp-substitute/global #f "_" str 'pre "-" 'post)) (define (format-c-header c-h) (regexp-substitute/global - #f "," + #f "," (regexp-substitute/global #f "(SCM|\\)|\\() *" (dashify-underscores c-h) - 'pre "" 'post) + 'pre "" 'post) 'pre " " 'post)) (define (document-scheme-function name c-header doc-string) @@ -36,16 +36,16 @@ "\n@end defun\n\n")) (define all-scheme-functions - (hash-fold - (lambda (key val prior) - (cons (cons key val) prior)) - '() (ly:get-all-function-documentation))) + (hash-fold + (lambda (key val prior) + (cons (cons key val) prior)) + '() (ly:get-all-function-documentation))) (define (all-scheme-functions-doc) (let* ((fdocs (map (lambda (x) - (document-scheme-function (car x) (cadr x) (cddr x))) - all-scheme-functions)) - (sfdocs (sort fdocs ly:string-ci<?))) + (document-scheme-function (car x) (cadr x) (cddr x))) + all-scheme-functions)) + (sfdocs (sort fdocs ly:string-ci<?))) (make <texi-node> #:name "Scheme functions" #:desc "Primitive functions exported by LilyPond." diff --git a/scm/document-identifiers.scm b/scm/document-identifiers.scm index fcd8f93214..e17f7d308c 100644 --- a/scm/document-identifiers.scm +++ b/scm/document-identifiers.scm @@ -23,32 +23,32 @@ (music-func (cdr music-func-pair)) (func (ly:music-function-extract music-func)) (arg-names - (map symbol->string - (cddr (cadr (procedure-source func))))) + (map symbol->string + (cddr (cadr (procedure-source func))))) (doc (procedure-documentation func)) (sign (ly:music-function-signature music-func)) (type-names (map (lambda (pred) - (if (pair? pred) - (format #f "[~a]" (type-name (car pred))) - (format #f "(~a)" (type-name pred)))) - sign)) + (if (pair? pred) + (format #f "[~a]" (type-name (car pred))) + (format #f "(~a)" (type-name pred)))) + sign)) (signature-str - (string-join - (map (lambda (arg type) (format #f "@var{~a} ~a" arg type)) - arg-names (cdr type-names))))) + (string-join + (map (lambda (arg type) (format #f "@var{~a} ~a" arg type)) + arg-names (cdr type-names))))) (format #f - "@item @code{~a} ~a ~a~a + "@item @code{~a} ~a ~a~a @funindex ~a ~a " - name-sym (car type-names) - (if (equal? "" signature-str) "" " - ") signature-str - name-sym - (if doc - doc - (begin - (ly:warning "music function `~a' not documented." name-sym) - "(undocumented; fixme)"))))) + name-sym (car type-names) + (if (equal? "" signature-str) "" " - ") signature-str + name-sym + (if doc + doc + (begin + (ly:warning "music function `~a' not documented." name-sym) + "(undocumented; fixme)"))))) (define (document-object obj-pair) @@ -60,16 +60,16 @@ (define-public (identifiers-doc-string) (format #f - "@table @asis + "@table @asis ~a @end table " - (string-join - (filter - identity - (map - document-object - (sort - (ly:module->alist (current-module)) - identifier<?))) - ""))) + (string-join + (filter + identity + (map + document-object + (sort + (ly:module->alist (current-module)) + identifier<?))) + ""))) diff --git a/scm/document-markup.scm b/scm/document-markup.scm index ea335f7e29..fd8f012b43 100644 --- a/scm/document-markup.scm +++ b/scm/document-markup.scm @@ -78,13 +78,13 @@ (define (markup-category-doc-node category) (let* ((category-string (symbol->string category)) (category-name (string-capitalize - (regexp-substitute/global - #f "-" category-string 'pre " " 'post))) - (markup-functions (hash-fold (lambda (markup-function dummy functions) - (cons markup-function functions)) - '() - (hashq-ref markup-functions-by-category - category)))) + (regexp-substitute/global + #f "-" category-string 'pre " " 'post))) + (markup-functions (hash-fold (lambda (markup-function dummy functions) + (cons markup-function functions)) + '() + (hashq-ref markup-functions-by-category + category)))) (make <texi-node> #:appendix #t #:name category-name @@ -118,12 +118,12 @@ (string-append "@table @asis" (apply string-append - (map doc-markup-function - (sort (hash-fold (lambda (markup-list-function dummy functions) - (cons markup-list-function functions)) - '() - markup-list-functions) - markup-function<?))) + (map doc-markup-function + (sort (hash-fold (lambda (markup-list-function dummy functions) + (cons markup-list-function functions)) + '() + markup-list-functions) + markup-function<?))) "\n@end table")) diff --git a/scm/document-music.scm b/scm/document-music.scm index 7d7e2a9942..92c2b52487 100644 --- a/scm/document-music.scm +++ b/scm/document-music.scm @@ -24,40 +24,40 @@ #:desc "All music properties, including descriptions." #:text (let* ((ps (sort (map symbol->string all-music-properties) ly:string-ci<?)) - (descs (map (lambda (prop) - (property->texi 'music (string->symbol prop))) - ps)) - (texi (description-list->texi descs #f))) + (descs (map (lambda (prop) + (property->texi 'music (string->symbol prop))) + ps)) + (texi (description-list->texi descs #f))) texi))) (define music-types->names (make-hash-table 61)) (filter-map (lambda (entry) - (let* ((class (ly:camel-case->lisp-identifier (car entry))) - (classes (ly:make-event-class doc-context class))) - (if classes - (map - (lambda (cl) - (hashq-set! music-types->names cl - (cons (car entry) - (hashq-ref music-types->names cl '())))) - classes) - #f))) - - music-descriptions) + (let* ((class (ly:camel-case->lisp-identifier (car entry))) + (classes (ly:make-event-class doc-context class))) + (if classes + (map + (lambda (cl) + (hashq-set! music-types->names cl + (cons (car entry) + (hashq-ref music-types->names cl '())))) + classes) + #f))) + + music-descriptions) (define (strip-description x) (cons (symbol->string (car x)) - "")) + "")) (define (music-type-doc entry) (let* ((accept-list (human-listify - (map ref-ify - (map symbol->string - (map ly:translator-name - (filter - (lambda (x) - (engraver-accepts-music-type? (car entry) x)) - all-engravers-list))))))) + (map ref-ify + (map symbol->string + (map ly:translator-name + (filter + (lambda (x) + (engraver-accepts-music-type? (car entry) x)) + all-engravers-list))))))) (make <texi-node> #:name (symbol->string (car entry)) #:text @@ -66,16 +66,16 @@ (symbol->string (car entry)) "} is in music objects of type " (human-listify - (map ref-ify (sort (map symbol->string (cdr entry)) - ly:string-ci<?))) + (map ref-ify (sort (map symbol->string (cdr entry)) + ly:string-ci<?))) "." "\n\n" (if (equal? accept-list "none") - "Not accepted by any engraver or performer" - (string-append - "Accepted by: " - accept-list)) + "Not accepted by any engraver or performer" + (string-append + "Accepted by: " + accept-list)) ".")))) (define (music-types-doc) @@ -83,40 +83,40 @@ #:name "Music classes" #:children (map music-type-doc - (sort - (hash-table->alist music-types->names) ly:alist-ci<?)))) + (sort + (hash-table->alist music-types->names) ly:alist-ci<?)))) (define (music-doc-str obj) (let* ((namesym (car obj)) - (props (cdr obj)) - (class (ly:camel-case->lisp-identifier namesym)) - (classes (ly:make-event-class doc-context class)) - (accept-list (if classes - (human-listify - (map ref-ify - (map symbol->string - (map ly:translator-name - (filter - (lambda (x) - (engraver-accepts-music-types? classes x)) - all-engravers-list))))) - "")) - (event-texi (if classes - (string-append - "\n\nEvent classes:\n" - (human-listify - (map ref-ify (sort (map symbol->string classes) - ly:string-ci<?))) - "." + (props (cdr obj)) + (class (ly:camel-case->lisp-identifier namesym)) + (classes (ly:make-event-class doc-context class)) + (accept-list (if classes + (human-listify + (map ref-ify + (map symbol->string + (map ly:translator-name + (filter + (lambda (x) + (engraver-accepts-music-types? classes x)) + all-engravers-list))))) + "")) + (event-texi (if classes + (string-append + "\n\nEvent classes:\n" + (human-listify + (map ref-ify (sort (map symbol->string classes) + ly:string-ci<?))) + "." - "\n\n" - (if (equal? accept-list "none") - "Not accepted by any engraver or performer" - (string-append - "Accepted by: " - accept-list)) - ".") - ""))) + "\n\n" + (if (equal? accept-list "none") + "Not accepted by any engraver or performer" + (string-append + "Accepted by: " + accept-list)) + ".") + ""))) (string-append (object-property namesym 'music-description) diff --git a/scm/document-translation.scm b/scm/document-translation.scm index 00b22be7a3..8237260c45 100644 --- a/scm/document-translation.scm +++ b/scm/document-translation.scm @@ -31,80 +31,80 @@ (define (engraver-doc-string engraver in-which-contexts) (let* ((propsr (assoc-get 'properties-read (ly:translator-description engraver))) - (propsw (assoc-get 'properties-written (ly:translator-description engraver))) - (accepted (assoc-get 'events-accepted (ly:translator-description engraver))) - (name-sym (ly:translator-name engraver)) - (name-str (symbol->string name-sym)) - (desc (assoc-get 'description (ly:translator-description engraver))) - (grobs (engraver-grobs engraver))) + (propsw (assoc-get 'properties-written (ly:translator-description engraver))) + (accepted (assoc-get 'events-accepted (ly:translator-description engraver))) + (name-sym (ly:translator-name engraver)) + (name-str (symbol->string name-sym)) + (desc (assoc-get 'description (ly:translator-description engraver))) + (grobs (engraver-grobs engraver))) (string-append desc "\n\n" (if (pair? accepted) - (string-append - "Music types accepted:\n\n" - (human-listify - (map ref-ify (sort (map symbol->string accepted) ly:string-ci<?)))) - "") + (string-append + "Music types accepted:\n\n" + (human-listify + (map ref-ify (sort (map symbol->string accepted) ly:string-ci<?)))) + "") "\n\n" (if (pair? propsr) - (string-append - "Properties (read)" - (description-list->texi - (map (lambda (x) (property->texi 'translation x '())) - (sort propsr ly:symbol-ci<?)) - #t)) - "") + (string-append + "Properties (read)" + (description-list->texi + (map (lambda (x) (property->texi 'translation x '())) + (sort propsr ly:symbol-ci<?)) + #t)) + "") (if (null? propsw) - "" - (string-append - "Properties (write)" - (description-list->texi - (map (lambda (x) (property->texi 'translation x '())) - (sort propsw ly:symbol-ci<?)) - #t))) + "" + (string-append + "Properties (write)" + (description-list->texi + (map (lambda (x) (property->texi 'translation x '())) + (sort propsw ly:symbol-ci<?)) + #t))) (if (null? grobs) - "" - (string-append - "\n\nThis engraver creates the following layout object(s):\n\n" - (human-listify (map ref-ify (uniq-list (sort grobs ly:string-ci<?)))) - ".")) + "" + (string-append + "\n\nThis engraver creates the following layout object(s):\n\n" + (human-listify (map ref-ify (uniq-list (sort grobs ly:string-ci<?)))) + ".")) "\n\n" (if in-which-contexts - (let* ((layout-alist (ly:output-description $defaultlayout)) - (context-description-alist (map cdr layout-alist)) - (contexts - (apply append - (map - (lambda (x) - (let* ((context (assoc-get 'context-name x)) - (group (assq-ref x 'group-type)) - (consists (append - (if group - (list group) - '()) - (assoc-get 'consists x)))) - (if (member name-sym consists) - (list context) - '()))) - context-description-alist))) - (context-list (human-listify (map ref-ify - (sort - (map symbol->string contexts) - ly:string-ci<?))))) - (string-append - "@code{" name-str "} " - (if (equal? context-list "none") - "is not part of any context" - (string-append - "is part of the following context(s): " - context-list)) - ".")) - "")))) + (let* ((layout-alist (ly:output-description $defaultlayout)) + (context-description-alist (map cdr layout-alist)) + (contexts + (apply append + (map + (lambda (x) + (let* ((context (assoc-get 'context-name x)) + (group (assq-ref x 'group-type)) + (consists (append + (if group + (list group) + '()) + (assoc-get 'consists x)))) + (if (member name-sym consists) + (list context) + '()))) + context-description-alist))) + (context-list (human-listify (map ref-ify + (sort + (map symbol->string contexts) + ly:string-ci<?))))) + (string-append + "@code{" name-str "} " + (if (equal? context-list "none") + "is not part of any context" + (string-append + "is part of the following context(s): " + context-list)) + ".")) + "")))) ;; First level Engraver description (define (engraver-doc grav) @@ -129,45 +129,45 @@ (let* ((eg (find-engraver-by-name name))) (cons (string-append "@code{" (ref-ify (symbol->string name)) "}") - (engraver-doc-string eg #f)))) + (engraver-doc-string eg #f)))) (define (document-property-operation op) (let ((tag (car op)) - (context-sym (cadr op)) - (args (cddr op)) - ) + (context-sym (cadr op)) + (args (cddr op)) + ) (cond ((equal? tag 'push) (let* - ((value (car args)) - (path (cdr args))) - - (string-append - "@item Set " - (format #f "grob-property @code{~a} " - (string-join (map symbol->string path) " ")) - (format #f "in @ref{~a} to ~a." - context-sym (scm->texi value)) - "\n"))) + ((value (car args)) + (path (cdr args))) + + (string-append + "@item Set " + (format #f "grob-property @code{~a} " + (string-join (map symbol->string path) " ")) + (format #f "in @ref{~a} to ~a." + context-sym (scm->texi value)) + "\n"))) ((equal? (object-property context-sym 'is-grob?) #t) "") ((equal? tag 'assign) (format #f "@item Set translator property @code{~a} to ~a.\n" - context-sym - (scm->texi (car args)))) + context-sym + (scm->texi (car args)))) ))) (define (context-doc context-desc) (let* ((name-sym (assoc-get 'context-name context-desc)) - (name (symbol->string name-sym)) - (aliases (map symbol->string (assoc-get 'aliases context-desc))) - (desc (assoc-get 'description context-desc "(not documented")) - (accepts (assoc-get 'accepts context-desc)) - (consists (assoc-get 'consists context-desc)) - (props (assoc-get 'property-ops context-desc)) - (grobs (context-grobs context-desc)) - (grob-refs (map ref-ify (sort grobs ly:string-ci<?)))) + (name (symbol->string name-sym)) + (aliases (map symbol->string (assoc-get 'aliases context-desc))) + (desc (assoc-get 'description context-desc "(not documented")) + (accepts (assoc-get 'accepts context-desc)) + (consists (assoc-get 'consists context-desc)) + (props (assoc-get 'property-ops context-desc)) + (grobs (context-grobs context-desc)) + (grob-refs (map ref-ify (sort grobs ly:string-ci<?)))) (make <texi-node> #:name name @@ -175,72 +175,72 @@ (string-append desc (if (pair? aliases) - (string-append - "\n\nThis context also accepts commands for the following context(s):\n\n" - (human-listify (sort aliases ly:string-ci<?)) - ".") - "") + (string-append + "\n\nThis context also accepts commands for the following context(s):\n\n" + (human-listify (sort aliases ly:string-ci<?)) + ".") + "") "\n\nThis context creates the following layout object(s):\n\n" (human-listify (uniq-list grob-refs)) "." (if (and (pair? props) (not (null? props))) - (let ((str (apply string-append - (sort (map document-property-operation props) - ly:string-ci<?)))) - (if (string-null? str) - "" - (string-append - "\n\nThis context sets the following properties:\n\n" - "@itemize @bullet\n" - str - "@end itemize\n"))) - "") + (let ((str (apply string-append + (sort (map document-property-operation props) + ly:string-ci<?)))) + (if (string-null? str) + "" + (string-append + "\n\nThis context sets the following properties:\n\n" + "@itemize @bullet\n" + str + "@end itemize\n"))) + "") (if (null? accepts) - "\n\nThis context is a `bottom' context; it cannot contain other contexts." - (string-append - "\n\nContext " - name - " can contain\n" - (human-listify (map ref-ify (sort (map symbol->string accepts) - ly:string-ci<?))) - ".")) + "\n\nThis context is a `bottom' context; it cannot contain other contexts." + (string-append + "\n\nContext " + name + " can contain\n" + (human-listify (map ref-ify (sort (map symbol->string accepts) + ly:string-ci<?))) + ".")) (if (null? consists) - "" - (string-append - "\n\nThis context is built from the following engraver(s):" - (description-list->texi - (map document-engraver-by-name (sort consists ly:symbol-ci<?)) - #t))))))) + "" + (string-append + "\n\nThis context is built from the following engraver(s):" + (description-list->texi + (map document-engraver-by-name (sort consists ly:symbol-ci<?)) + #t))))))) (define (engraver-grobs grav) (let* ((eg (if (symbol? grav) - (find-engraver-by-name grav) - grav))) + (find-engraver-by-name grav) + grav))) (if (eq? eg #f) - '() - (map symbol->string (assoc-get 'grobs-created (ly:translator-description eg)))))) + '() + (map symbol->string (assoc-get 'grobs-created (ly:translator-description eg)))))) (define (context-grobs context-desc) (let* ((group (assq-ref context-desc 'group-type)) - (consists (append - (if group - (list group) - '()) - (assoc-get 'consists context-desc))) - (grobs (apply append - (map engraver-grobs consists)))) + (consists (append + (if group + (list group) + '()) + (assoc-get 'consists context-desc))) + (grobs (apply append + (map engraver-grobs consists)))) grobs)) (define (all-contexts-doc) (let* ((layout-alist - (sort (ly:output-description $defaultlayout) - (lambda (x y) (ly:symbol-ci<? (car x) (car y))))) - (names (sort (map symbol->string (map car layout-alist)) ly:string-ci<?)) - (contexts (map cdr layout-alist))) + (sort (ly:output-description $defaultlayout) + (lambda (x y) (ly:symbol-ci<? (car x) (car y))))) + (names (sort (map symbol->string (map car layout-alist)) ly:string-ci<?)) + (contexts (map cdr layout-alist))) (make <texi-node> #:name "Contexts" @@ -251,8 +251,8 @@ (define all-engravers-list (ly:get-all-translators)) (set! all-engravers-list (sort all-engravers-list - (lambda (a b) (ly:string-ci<? (symbol->string (ly:translator-name a)) - (symbol->string (ly:translator-name b)))))) + (lambda (a b) (ly:string-ci<? (symbol->string (ly:translator-name a)) + (symbol->string (ly:translator-name b)))))) (define (all-engravers-doc) (make <texi-node> @@ -264,12 +264,12 @@ (define (translation-properties-doc-string lst) (let* ((ps (sort (map symbol->string lst) ly:string-ci<?)) - (sortedsyms (map string->symbol ps)) - (propdescs - (map - (lambda (x) (property->texi 'translation x '())) - sortedsyms)) - (texi (description-list->texi propdescs #f))) + (sortedsyms (map string->symbol ps)) + (propdescs + (map + (lambda (x) (property->texi 'translation x '())) + sortedsyms)) + (texi (description-list->texi propdescs #f))) texi)) (define (translation-doc-node) @@ -284,10 +284,10 @@ #:name "Tunable context properties" #:desc "All tunable context properties." #:text (translation-properties-doc-string - all-user-translation-properties)) + all-user-translation-properties)) (make <texi-node> #:name "Internal context properties" #:desc "All internal context properties." #:text (translation-properties-doc-string - all-internal-translation-properties))))) + all-internal-translation-properties))))) diff --git a/scm/documentation-generate.scm b/scm/documentation-generate.scm index 88016c92ae..00286238b3 100644 --- a/scm/documentation-generate.scm +++ b/scm/documentation-generate.scm @@ -28,15 +28,15 @@ ;; todo: naming: grob vs. layout property (map ly:load '("documentation-lib.scm" - "lily-sort.scm" - "document-functions.scm" - "document-translation.scm" - "document-music.scm" - "document-type-predicates.scm" - "document-identifiers.scm" - "document-context-mods.scm" - "document-backend.scm" - "document-markup.scm")) + "lily-sort.scm" + "document-functions.scm" + "document-translation.scm" + "document-music.scm" + "document-type-predicates.scm" + "document-identifiers.scm" + "document-context-mods.scm" + "document-backend.scm" + "document-markup.scm")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -97,7 +97,7 @@ (display (string-append (texi-file-head "LilyPond Internals Reference" file-name - "(lilypond-internals.info)") + "(lilypond-internals.info)") " @include macros.itexi @@ -156,8 +156,8 @@ This document is also available as a @end ifhtml This is the Internals Reference (IR) for version " - (lilypond-version) - " of LilyPond, the GNU music typesetter.") + (lilypond-version) + " of LilyPond, the GNU music typesetter.") #:children (list diff --git a/scm/documentation-lib.scm b/scm/documentation-lib.scm index 182f581272..b8c0f097a6 100644 --- a/scm/documentation-lib.scm +++ b/scm/documentation-lib.scm @@ -17,8 +17,8 @@ ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>. (use-modules (oop goops) - (srfi srfi-13) - (srfi srfi-1)) + (srfi srfi-13) + (srfi srfi-1)) (define-class <texi-node> () (appendix #:init-value #f #:accessor appendix? #:init-keyword #:appendix) @@ -47,10 +47,10 @@ (node-text node) "\n\n" (if (pair? (node-children node)) - (texi-menu - (map (lambda (x) (menu-entry x)) - (node-children node))) - "")) + (texi-menu + (map (lambda (x) (menu-entry x)) + (node-children node))) + "")) port) (map (lambda (x) (dump-node x port (+ 1 level))) (node-children node))) @@ -71,21 +71,21 @@ (define (texi-section-command level) (assoc-get level '( - ;; Hmm, texinfo doesn't have ``part'' - (0 . "@top") - (1 . "@chapter") - (2 . "@section") - (3 . "@subsection") - (4 . "@unnumberedsubsubsec") - (5 . "@unnumberedsubsubsec")))) + ;; Hmm, texinfo doesn't have ``part'' + (0 . "@top") + (1 . "@chapter") + (2 . "@section") + (3 . "@subsection") + (4 . "@unnumberedsubsubsec") + (5 . "@unnumberedsubsubsec")))) (define (texi-appendix-section-command level) (assoc-get level '((0 . "@top") - (1 . "@appendix") - (2 . "@appendixsec") - (3 . "@appendixsubsec") - (4 . "@appendixsubsubsec") - (5 . "@appendixsubsubsec")))) + (1 . "@appendix") + (2 . "@appendixsec") + (3 . "@appendixsubsec") + (4 . "@appendixsubsubsec") + (5 . "@appendixsubsubsec")))) (define (one-item->texi label-desc-pair) "Document one (LABEL . DESC); return empty string if LABEL is empty string." @@ -109,25 +109,25 @@ string-to-use). If QUOTE? is #t, embed table in a @quotation environment." (define (texi-menu items-alist) "Generate what is between @menu and @end menu." (let ((maxwid - (apply max (map (lambda (x) (string-length (car x))) items-alist)))) + (apply max (map (lambda (x) (string-length (car x))) items-alist)))) (string-append "\n@menu" (apply string-append - (map (lambda (x) - (string-append - (string-pad-right - (string-append "\n* " (car x) ":: ") - (+ maxwid 8)) - (cdr x))) - items-alist)) + (map (lambda (x) + (string-append + (string-pad-right + (string-append "\n* " (car x) ":: ") + (+ maxwid 8)) + (cdr x))) + items-alist)) "\n@end menu\n" ;; Menus don't appear in html, so we make a list ourselves "\n@ignore\n" "\n@ifhtml\n" (description-list->texi (map (lambda (x) (cons (ref-ify (car x)) (cdr x))) - items-alist) - #t) + items-alist) + #t) "\n@end ifhtml\n" "\n@end ignore\n"))) @@ -195,27 +195,27 @@ string-to-use). If QUOTE? is #t, embed table in a @quotation environment." with init values from ALIST (1st optional argument) " (let* ((name (symbol->string sym)) - (alist (if (pair? rest) (car rest) '())) - (type?-name (string->symbol - (string-append (symbol->string where) "-type?"))) - (doc-name (string->symbol - (string-append (symbol->string where) "-doc"))) - (type (object-property sym type?-name)) - (typename (verify-type-name where sym type)) - (desc (object-property sym doc-name)) - (init-value (assoc-get sym alist))) + (alist (if (pair? rest) (car rest) '())) + (type?-name (string->symbol + (string-append (symbol->string where) "-type?"))) + (doc-name (string->symbol + (string-append (symbol->string where) "-doc"))) + (type (object-property sym type?-name)) + (typename (verify-type-name where sym type)) + (desc (object-property sym doc-name)) + (init-value (assoc-get sym alist))) (if (eq? desc #f) - (ly:error (_ "cannot find description for property ~S (~S)") sym where)) + (ly:error (_ "cannot find description for property ~S (~S)") sym where)) (cons (string-append "@code{" name "} " - "(" typename ")" - (if init-value - (string-append - ":\n\n" - (scm->texi init-value) - "\n\n") - "")) + "(" typename ")" + (if init-value + (string-append + ":\n\n" + (scm->texi init-value) + "\n\n") + "")) desc))) diff --git a/scm/editor.scm b/scm/editor.scm index 66c3709fb2..e474a557e5 100644 --- a/scm/editor.scm +++ b/scm/editor.scm @@ -36,9 +36,9 @@ ;; FIXME: how are default/preferred editors specified on ;; different platforms? (case PLATFORM - ((windows) "lilypad") - (else - "emacs")))) + ((windows) "lilypad") + (else + "emacs")))) (define editor-command-template-alist '(("emacs" . "emacsclient --no-wait +%(line)s:%(column)s %(file)s || (emacs +%(line)s:%(column)s %(file)s&)") @@ -53,12 +53,12 @@ (define (get-command-template alist editor) (define (get-command-template-helper) (if (null? alist) - (if (string-match "%\\(file\\)s" editor) - editor - (string-append editor " %(file)s")) - (if (string-match (caar alist) editor) - (cdar alist) - (get-command-template (cdr alist) editor)))) + (if (string-match "%\\(file\\)s" editor) + editor + (string-append editor " %(file)s")) + (if (string-match (caar alist) editor) + (cdar alist) + (get-command-template (cdr alist) editor)))) (if (string-match "%\\(file\\)s" editor) editor (get-command-template-helper))) @@ -67,18 +67,18 @@ (regexp-substitute/global #f re string 'pre sub 'post)) (define (slashify x) - (if (string-index x #\/) - x - (re-sub "\\\\" "/" x))) + (if (string-index x #\/) + x + (re-sub "\\\\" "/" x))) (define-public (get-editor-command file-name line char column) (let* ((editor (get-editor)) - (template (get-command-template editor-command-template-alist editor)) - (command - (re-sub "%\\(file\\)s" (format #f "~S" file-name) - (re-sub "%\\(line\\)s" (format #f "~a" line) - (re-sub "%\\(char\\)s" (format #f "~a" char) - (re-sub - "%\\(column\\)s" (format #f "~a" column) - (slashify template))))))) + (template (get-command-template editor-command-template-alist editor)) + (command + (re-sub "%\\(file\\)s" (format #f "~S" file-name) + (re-sub "%\\(line\\)s" (format #f "~a" line) + (re-sub "%\\(char\\)s" (format #f "~a" char) + (re-sub + "%\\(column\\)s" (format #f "~a" column) + (slashify template))))))) command)) diff --git a/scm/encoding.scm b/scm/encoding.scm index 1868e7600f..aaeed727b1 100644 --- a/scm/encoding.scm +++ b/scm/encoding.scm @@ -17,44 +17,44 @@ (define-public latin1-coding-vector #(.notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef - .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef - .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef - .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef - %% 0x20 - space exclam quotedbl numbersign dollar percent ampersand quoteright - parenleft parenright asterisk plus comma hyphen period slash - zero one two three four five six seven - eight nine colon semicolon less equal greater question - %% 0x40 - at A B C D E F G - H I J K L M N O - P Q R S T U V W - X Y Z bracketleft backslash bracketright asciicircum underscore - %% 0x60 - `quoteleft a b c d e f g - h i j k l m n o - p q r s t u v w - x y z braceleft bar braceright asciitilde .notdef - %% 0x80 - .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef - .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef - dotlessi grave acute circumflex tilde macron breve dotaccent - dieresis .notdef ring cedilla .notdef hungarumlaut ogonek caron - %% 0xA0 - space exclamdown cent sterling currency yen brokenbar section - dieresis copyright ordfeminine guillemotleft logicalnot hyphen registered macron - degree plusminus twosuperior threesuperior acute mu paragraph periodcentered - cedilla onesuperior ordmasculine guillemotright onequarter onehalf threequarters questiondown - %% 0xC0 - Agrave Aacute Acircumflex Atilde Adieresis Aring AE Ccedilla - Egrave Eacute Ecircumflex Edieresis Igrave Iacute Icircumflex Idieresis - Eth Ntilde Ograve Oacute Ocircumflex Otilde Odieresis multiply - Oslash Ugrave Uacute Ucircumflex Udieresis Yacute Thorn germandbls - %% 0xE0 - agrave aacute acircumflex atilde adieresis aring ae ccedilla - egrave eacute ecircumflex edieresis igrave iacute icircumflex idieresis - eth ntilde ograve oacute ocircumflex otilde odieresis divide - oslash ugrave uacute ucircumflex udieresis yacute thorn ydieresis)) + .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef + .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef + .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef + %% 0x20 + space exclam quotedbl numbersign dollar percent ampersand quoteright + parenleft parenright asterisk plus comma hyphen period slash + zero one two three four five six seven + eight nine colon semicolon less equal greater question + %% 0x40 + at A B C D E F G + H I J K L M N O + P Q R S T U V W + X Y Z bracketleft backslash bracketright asciicircum underscore + %% 0x60 + `quoteleft a b c d e f g + h i j k l m n o + p q r s t u v w + x y z braceleft bar braceright asciitilde .notdef + %% 0x80 + .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef + .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef + dotlessi grave acute circumflex tilde macron breve dotaccent + dieresis .notdef ring cedilla .notdef hungarumlaut ogonek caron + %% 0xA0 + space exclamdown cent sterling currency yen brokenbar section + dieresis copyright ordfeminine guillemotleft logicalnot hyphen registered macron + degree plusminus twosuperior threesuperior acute mu paragraph periodcentered + cedilla onesuperior ordmasculine guillemotright onequarter onehalf threequarters questiondown + %% 0xC0 + Agrave Aacute Acircumflex Atilde Adieresis Aring AE Ccedilla + Egrave Eacute Ecircumflex Edieresis Igrave Iacute Icircumflex Idieresis + Eth Ntilde Ograve Oacute Ocircumflex Otilde Odieresis multiply + Oslash Ugrave Uacute Ucircumflex Udieresis Yacute Thorn germandbls + %% 0xE0 + agrave aacute acircumflex atilde adieresis aring ae ccedilla + egrave eacute ecircumflex edieresis igrave iacute icircumflex idieresis + eth ntilde ograve oacute ocircumflex otilde odieresis divide + oslash ugrave uacute ucircumflex udieresis yacute thorn ydieresis)) (define-public (decode-byte-string str) @@ -62,10 +62,10 @@ assuming that @var{str} is byte-coded using latin-1 encoding." (let* ((len (string-length str)) - (output-vector (make-vector len '.notdef))) + (output-vector (make-vector len '.notdef))) (do - ((idx 0 (1+ idx))) - ((>= idx len) output-vector) + ((idx 0 (1+ idx))) + ((>= idx len) output-vector) (vector-set! output-vector idx - (vector-ref latin1-coding-vector - (char->integer (string-ref str idx))))))) + (vector-ref latin1-coding-vector + (char->integer (string-ref str idx))))))) diff --git a/scm/file-cache.scm b/scm/file-cache.scm index 221a6e2837..21db866eb8 100644 --- a/scm/file-cache.scm +++ b/scm/file-cache.scm @@ -22,7 +22,7 @@ ((contents (hash-ref cache-hash-tab filename #f))) (if (not (string? contents)) - (begin - (set! contents (ly:gulp-file filename)) - (hash-set! cache-hash-tab filename contents))) + (begin + (set! contents (ly:gulp-file filename)) + (hash-set! cache-hash-tab filename contents))) contents)) diff --git a/scm/flag-styles.scm b/scm/flag-styles.scm index 6027161995..0b5750280f 100644 --- a/scm/flag-styles.scm +++ b/scm/flag-styles.scm @@ -90,22 +90,22 @@ All lengths are scaled according to the font size of the note." (points (if stem-up (list start flag-end (offset-add flag-end thickness-offset) (offset-add start thickness-offset)) - (list start - (offset-add start thickness-offset) - (offset-add flag-end thickness-offset) - flag-end))) + (list start + (offset-add start thickness-offset) + (offset-add flag-end thickness-offset) + flag-end))) (stencil (ly:round-filled-polygon points half-stem-thickness)) ;; Log for 1/8 is 3, so we need to subtract 3 (flag-stencil (buildflag stencil (- log 3) stencil spacing)) (stroke-style (ly:grob-property grob 'stroke-style))) - (if (equal? stroke-style "grace") - (add-stroke-straight flag-stencil grob - dir log - stroke-style - flag-end flag-length - thickness - (* half-stem-thickness 2)) - flag-stencil)))) + (if (equal? stroke-style "grace") + (add-stroke-straight flag-stencil grob + dir log + stroke-style + flag-end flag-length + thickness + (* half-stem-thickness 2)) + flag-stencil)))) (define-public (modern-straight-flag grob) "Modern straight flag style (for composers like Stockhausen, Boulez, etc.). @@ -136,21 +136,21 @@ flags are both 45 degrees." "Load and add a stroke (represented by a glyph in the font) to the given flag stencil." (if (not (string? stroke-style)) - stencil - ;; Otherwise: look up the stroke glyph and combine it with the flag - (let* ((stem-grob (ly:grob-parent grob X)) - (font-char (string-append "flags." flag-style dir stroke-style)) - (alt-font-char (string-append "flags." dir stroke-style)) - (font (ly:grob-default-font grob)) - (tmpstencil (ly:font-get-glyph font font-char)) - (stroke-stencil (if (ly:stencil-empty? tmpstencil) - (ly:font-get-glyph font alt-font-char) - tmpstencil))) - (if (ly:stencil-empty? stroke-stencil) - (begin - (ly:warning (_ "flag stroke `~a' or `~a' not found") font-char alt-font-char) - stencil) - (ly:stencil-add stencil stroke-stencil))))) + stencil + ;; Otherwise: look up the stroke glyph and combine it with the flag + (let* ((stem-grob (ly:grob-parent grob X)) + (font-char (string-append "flags." flag-style dir stroke-style)) + (alt-font-char (string-append "flags." dir stroke-style)) + (font (ly:grob-default-font grob)) + (tmpstencil (ly:font-get-glyph font font-char)) + (stroke-stencil (if (ly:stencil-empty? tmpstencil) + (ly:font-get-glyph font alt-font-char) + tmpstencil))) + (if (ly:stencil-empty? stroke-stencil) + (begin + (ly:warning (_ "flag stroke `~a' or `~a' not found") font-char alt-font-char) + stencil) + (ly:stencil-add stencil stroke-stencil))))) (define-public (retrieve-glyph-flag flag-style dir dir-modifier grob) @@ -161,7 +161,7 @@ flag stencil." (font-char (string-append "flags." flag-style dir dir-modifier (number->string log))) (flag (ly:font-get-glyph font font-char))) (if (ly:stencil-empty? flag) - (ly:warning "flag ~a not found" font-char)) + (ly:warning "flag ~a not found" font-char)) flag)) @@ -172,8 +172,8 @@ flag stencil." (flag (retrieve-glyph-flag flag-style dir dir-modifier grob)) (stroke-style (ly:grob-property grob 'stroke-style))) (if (null? stroke-style) - flag - (add-stroke-glyph flag grob dir stroke-style flag-style)))) + flag + (add-stroke-glyph flag grob dir stroke-style flag-style)))) @@ -191,10 +191,10 @@ a flag always touches a staff line." (d (ly:grob-property stem-grob 'direction)) (ss (ly:staff-symbol-staff-space stem-grob)) (stem-end (inexact->exact (round (* (index-cell - (ly:grob-extent stem-grob - stem-grob - Y) - d) + (ly:grob-extent stem-grob + stem-grob + Y) + d) (/ 2 ss))))) ;; For some reason the stem-end is a real instead of an integer... (dir-modifier (if (ly:position-on-line? stem-grob stem-end) "1" "0")) @@ -236,7 +236,7 @@ at will. The correct way to do this is: (symbol->string flag-style-symbol) ""))) (cond - ((equal? flag-style "") (normal-flag grob)) - ((equal? flag-style "mensural") (mensural-flag grob)) - ((equal? flag-style "no-flag") (no-flag grob)) - (else ((glyph-flag flag-style) grob))))) + ((equal? flag-style "") (normal-flag grob)) + ((equal? flag-style "mensural") (mensural-flag grob)) + ((equal? flag-style "no-flag") (no-flag grob)) + (else ((glyph-flag flag-style) grob))))) diff --git a/scm/font.scm b/scm/font.scm index d759d60934..8753019fa7 100644 --- a/scm/font.scm +++ b/scm/font.scm @@ -43,7 +43,7 @@ (make <Font-tree-leaf> #:default-size size #:size-vector size-font-vector)) (define (make-font-tree-node - qualifier default) + qualifier default) (make <Font-tree-node> #:qualifier qualifier #:default default @@ -52,11 +52,11 @@ (define-method (display (leaf <Font-tree-leaf>) port) (map (lambda (x) (display x port)) (list - "#<Font-size-family:\n" - (slot-ref leaf 'default-size) - (slot-ref leaf 'size-vector) - "#>" - ))) + "#<Font-size-family:\n" + (slot-ref leaf 'default-size) + (slot-ref leaf 'size-vector) + "#>" + ))) (define-method (display (node <Font-tree-node>) port) (map @@ -84,10 +84,10 @@ (define (make-node fprops size-family) (if (null? fprops) - (make-font-tree-leaf (car size-family) (cdr size-family)) - (let* ((qual (next-qualifier default-qualifier-order fprops))) - (make-font-tree-node qual - (assoc-get qual fprops))))) + (make-font-tree-leaf (car size-family) (cdr size-family)) + (let* ((qual (next-qualifier default-qualifier-order fprops))) + (make-font-tree-node qual + (assoc-get qual fprops))))) (define (next-qualifier order props) (cond @@ -97,34 +97,34 @@ ((null? order) (caar props)) (else (if (assoc-get (car order) props) - (car order) - (next-qualifier (cdr order) props))))) + (car order) + (next-qualifier (cdr order) props))))) (let* ((q (font-qualifier node)) - (d (font-default node)) - (v (assoc-get q fprops d)) - (new-fprops (assoc-delete q fprops)) - (child (hashq-ref (slot-ref node 'children) - v #f))) + (d (font-default node)) + (v (assoc-get q fprops d)) + (new-fprops (assoc-delete q fprops)) + (child (hashq-ref (slot-ref node 'children) + v #f))) (if (not child) - (begin - (set! child (make-node new-fprops size-family)) - (hashq-set! (slot-ref node 'children) v child))) + (begin + (set! child (make-node new-fprops size-family)) + (hashq-set! (slot-ref node 'children) v child))) (if (pair? new-fprops) - (add-font child new-fprops size-family)))) + (add-font child new-fprops size-family)))) (define-method (add-font (node <Font-tree-leaf>) fprops size-family) (throw "must add to node, not leaf")) (define-method (g-lookup-font (node <Font-tree-node>) alist-chain) (let* ((qual (font-qualifier node)) - (def (font-default node)) - (val (chain-assoc-get qual alist-chain def)) - (desired-child (hashq-ref (font-children node) val))) + (def (font-default node)) + (val (chain-assoc-get qual alist-chain def)) + (desired-child (hashq-ref (font-children node) val))) (if desired-child - (g-lookup-font desired-child alist-chain) - (g-lookup-font (hashq-ref (font-children node) def) alist-chain)))) + (g-lookup-font desired-child alist-chain) + (g-lookup-font (hashq-ref (font-children node) def) alist-chain)))) (define-method (g-lookup-font (node <Font-tree-leaf>) alist-chain) node) @@ -176,32 +176,32 @@ used. This is used to select the proper design size for the text fonts. (for-each (lambda (x) (add-font node - (list (cons 'font-encoding (car x)) - (cons 'font-family family)) - (cons (* factor (cadr x)) - (caddr x)))) - + (list (cons 'font-encoding (car x)) + (cons 'font-family family)) + (cons (* factor (cadr x)) + (caddr x)))) + `((fetaText ,(ly:pt 20.0) - ,(list->vector - (map (lambda (tup) - (cons (ly:pt (cdr tup)) - (format #f "~a-~a ~a" - name - (car tup) - (ly:pt (cdr tup))))) - design-size-alist))) + ,(list->vector + (map (lambda (tup) + (cons (ly:pt (cdr tup)) + (format #f "~a-~a ~a" + name + (car tup) + (ly:pt (cdr tup))))) + design-size-alist))) (fetaMusic ,(ly:pt 20.0) - ,(list->vector - (map (lambda (size-tup) - (delay (ly:system-font-load - (format #f "~a-~a" name (car size-tup))))) - design-size-alist - ))) + ,(list->vector + (map (lambda (size-tup) + (delay (ly:system-font-load + (format #f "~a-~a" name (car size-tup))))) + design-size-alist + ))) (fetaBraces ,(ly:pt 20.0) - #(,(delay (ly:system-font-load - (format #f "~a-brace" name))))) + #(,(delay (ly:system-font-load + (format #f "~a-brace" name))))) ))) - + (define-public (add-pango-fonts node lily-family family factor) ;; Synchronized with the `text-font-size' variable in ;; layout-set-absolute-staff-size-in-module (see paper.scm). @@ -209,19 +209,19 @@ used. This is used to select the proper design size for the text fonts. (define (add-node shape series) (add-font node - `((font-family . ,lily-family) - (font-shape . ,shape) - (font-series . ,series) - (font-encoding . latin1) ;; ugh. - ) - `(,text-font-size - . #(,(cons - (ly:pt 12) - (ly:make-pango-description-string - `(((font-family . ,family) - (font-series . ,series) - (font-shape . ,shape))) - (ly:pt 12))))))) + `((font-family . ,lily-family) + (font-shape . ,shape) + (font-series . ,series) + (font-encoding . latin1) ;; ugh. + ) + `(,text-font-size + . #(,(cons + (ly:pt 12) + (ly:make-pango-description-string + `(((font-family . ,family) + (font-series . ,series) + (font-shape . ,shape))) + (ly:pt 12))))))) (add-node 'upright 'normal) (add-node 'caps 'normal) @@ -239,8 +239,8 @@ used. This is used to select the proper design size for the text fonts. (define-public (make-century-schoolbook-tree factor) (make-pango-font-tree - "Century Schoolbook L" - "sans-serif" "monospace" factor)) + "Century Schoolbook L" + "sans-serif" "monospace" factor)) (define-public all-text-font-encodings '(latin1)) diff --git a/scm/framework-eps.scm b/scm/framework-eps.scm index 697073642d..c0087f46d2 100644 --- a/scm/framework-eps.scm +++ b/scm/framework-eps.scm @@ -20,15 +20,15 @@ ;;; this is still too big a mess. (use-modules (ice-9 regex) - (ice-9 string-fun) - (guile) - (scm framework-ps) - (scm paper-system) - (scm page) - (scm output-ps) - (srfi srfi-1) - (srfi srfi-13) - (lily)) + (ice-9 string-fun) + (guile) + (scm framework-ps) + (scm paper-system) + (scm page) + (scm output-ps) + (srfi srfi-1) + (srfi srfi-13) + (lily)) (define format ergonomic-simple-format) @@ -42,18 +42,18 @@ stencil so that LaTeX's \\includegraphics command doesn't modify the alignment." (define left (if (pair? stencils) - (apply min - (map (lambda (stc) - (interval-start (ly:stencil-extent stc X))) - stencils)) - 0.0)) + (apply min + (map (lambda (stc) + (interval-start (ly:stencil-extent stc X))) + stencils)) + 0.0)) (map (lambda (stil) - (ly:make-stencil - (ly:stencil-expr stil) - (cons left - (cdr (ly:stencil-extent stil X))) - (ly:stencil-extent stil Y))) + (ly:make-stencil + (ly:stencil-expr stil) + (cons left + (cdr (ly:stencil-extent stil X))) + (ly:stencil-extent stil Y))) stencils)) (define (dump-stencils-as-EPSes stencils book basename) @@ -62,7 +62,7 @@ alignment." (define paper (ly:paper-book-paper book)) - + (define create-aux-files (ly:get-option 'aux-files)) @@ -73,86 +73,86 @@ alignment." (define (dump-counted-stencil stencil-count-pair) "Return EPS filename." (let* ((stencil (car stencil-count-pair)) - (number (cdr stencil-count-pair)) - (name (format #f "~a-~a" basename number))) + (number (cdr stencil-count-pair)) + (name (format #f "~a-~a" basename number))) (dump-stencil-as-EPS paper stencil name - (ly:get-option 'include-eps-fonts)) + (ly:get-option 'include-eps-fonts)) (string-append name ".eps"))) ;; main body - ;; First, create the output, then if necessary, individual staves and + ;; First, create the output, then if necessary, individual staves and ;; finally write some auxiliary files if desired (dump-infinite-stack-EPS stencils) (postprocess-output book framework-eps-module - (format #f "~a.eps" basename) (ly:output-formats)) + (format #f "~a.eps" basename) (ly:output-formats)) ;; individual staves (*-1.eps etc.); only print if more than one stencil ;; Otherwise the .eps and the -1.eps file will be identical and waste space ;; Also always create if aux-files=##t (if (or create-aux-files (< 1 (length stencils))) - (let* ((widened-stencils (widen-left-stencil-edges stencils)) - (counted-systems (count-list widened-stencils)) - (eps-files (map dump-counted-stencil counted-systems))) - (if do-pdf - ;; par-for-each: a bit faster ... - (for-each (lambda (y) (postscript->pdf 0 0 y)) - eps-files)))) + (let* ((widened-stencils (widen-left-stencil-edges stencils)) + (counted-systems (count-list widened-stencils)) + (eps-files (map dump-counted-stencil counted-systems))) + (if do-pdf + ;; par-for-each: a bit faster ... + (for-each (lambda (y) (postscript->pdf 0 0 y)) + eps-files)))) ;; Now, write some aux files if requested: .texi, .tex and .count ;; for direct inclusion into latex and texinfo (if create-aux-files - (let* ((write-file (lambda (str-port ext) - (if create-aux-files - (let* ((name (format #f "~a-systems.~a" basename ext)) - (port (open-output-file name))) - (ly:message (_ "Writing ~a...") name) - (display (get-output-string str-port) port) - (close-output-port port))))) - (tex-system-port (open-output-string)) - (texi-system-port (open-output-string)) - (count-system-port (open-output-string))) - (for-each (lambda (c) - (if (< 0 c) - (format tex-system-port - "\\ifx\\betweenLilyPondSystem \\undefined + (let* ((write-file (lambda (str-port ext) + (if create-aux-files + (let* ((name (format #f "~a-systems.~a" basename ext)) + (port (open-output-file name))) + (ly:message (_ "Writing ~a...") name) + (display (get-output-string str-port) port) + (close-output-port port))))) + (tex-system-port (open-output-string)) + (texi-system-port (open-output-string)) + (count-system-port (open-output-string))) + (for-each (lambda (c) + (if (< 0 c) + (format tex-system-port + "\\ifx\\betweenLilyPondSystem \\undefined \\linebreak \\else \\expandafter\\betweenLilyPondSystem{~a}% \\fi " c)) - (format tex-system-port "\\includegraphics{~a-~a}%\n" - basename (1+ c)) - (format texi-system-port "@image{~a-~a}\n" - basename (1+ c))) - (iota (length stencils))) - (display "@c eof\n" texi-system-port) - (display "% eof\n" tex-system-port) - (format count-system-port "~a" (length stencils)) - (write-file texi-system-port "texi") - (write-file tex-system-port "tex") - ;; do this as the last action so we know the rest is complete if - ;; this file is present. - (write-file count-system-port "count")))) + (format tex-system-port "\\includegraphics{~a-~a}%\n" + basename (1+ c)) + (format texi-system-port "@image{~a-~a}\n" + basename (1+ c))) + (iota (length stencils))) + (display "@c eof\n" texi-system-port) + (display "% eof\n" tex-system-port) + (format count-system-port "~a" (length stencils)) + (write-file texi-system-port "texi") + (write-file tex-system-port "tex") + ;; do this as the last action so we know the rest is complete if + ;; this file is present. + (write-file count-system-port "count")))) (define-public (output-classic-framework basename book scopes fields) (output-scopes scopes fields basename) (if (ly:get-option 'dump-signatures) (write-system-signatures basename (ly:paper-book-systems book) 1)) (dump-stencils-as-EPSes (map paper-system-stencil - (ly:paper-book-systems book)) - book - basename)) + (ly:paper-book-systems book)) + book + basename)) (define-public (output-framework basename book scopes fields) (output-scopes scopes fields basename) (if (ly:get-option 'clip-systems) (clip-system-EPSes basename book)) (dump-stencils-as-EPSes (map page-stencil - (ly:paper-book-pages book)) - book - basename)) + (ly:paper-book-pages book)) + book + basename)) -; redefine to imports from framework-ps + ; redefine to imports from framework-ps (define convert-to-pdf convert-to-pdf) diff --git a/scm/framework-null.scm b/scm/framework-null.scm index bcc58142e5..9671527185 100644 --- a/scm/framework-null.scm +++ b/scm/framework-null.scm @@ -5,16 +5,16 @@ ) (use-modules (ice-9 regex) - (ice-9 string-fun) - (guile) - (srfi srfi-1) - (ice-9 pretty-print) - (srfi srfi-13) - (lily)) + (ice-9 string-fun) + (guile) + (srfi srfi-1) + (ice-9 pretty-print) + (srfi srfi-13) + (lily)) (define-public (output-framework channel book scopes fields) - + #t) (define-public output-classic-framework output-framework) diff --git a/scm/framework-ps.scm b/scm/framework-ps.scm index b412ab3269..7a9fb454ff 100644 --- a/scm/framework-ps.scm +++ b/scm/framework-ps.scm @@ -20,13 +20,13 @@ ;;; this is still too big a mess. (use-modules (ice-9 string-fun) - (guile) - (scm page) - (scm paper-system) - (srfi srfi-1) - (srfi srfi-13) - (scm clip-region) - (lily)) + (guile) + (scm page) + (scm paper-system) + (srfi srfi-1) + (srfi srfi-13) + (scm clip-region) + (lily)) (define format ergonomic-simple-format) @@ -37,7 +37,7 @@ (define-public (ps-font-command font) (let* ((name (ly:font-file-name font)) - (magnify (ly:font-magnification font))) + (magnify (ly:font-magnification font))) (string-append "magfont" (ly:string-substitute @@ -45,7 +45,7 @@ (ly:string-substitute "/" "_" (ly:string-substitute - "%" "_" name))) + "%" "_" name))) "m" (string-encode-integer (inexact->exact (round (* 1000 magnify))))))) (define (ps-define-pango-pf pango-pf font-name scaling) @@ -76,13 +76,13 @@ (string-append "/lily-output-units " - (number->string (/ (ly:bp 1))) " def %% millimeter\n" + (number->string (/ (ly:bp 1))) " def %% millimeter\n" (output-entry "staff-line-thickness" 'line-thickness) (output-entry "line-width" 'line-width) (output-entry "paper-size" 'papersizename) - (output-entry "staff-height" 'staff-height) ;junkme. + (output-entry "staff-height" 'staff-height) ;junkme. "/output-scale " - (number->string (ly:output-def-lookup layout 'output-scale)) " def\n" + (number->string (ly:output-def-lookup layout 'output-scale)) " def\n" (output-entry "page-height" 'paper-height) (output-entry "page-width" 'paper-width))) @@ -93,8 +93,8 @@ (format #f "%%Page: ~a ~a\n" page-number page-number) "%%BeginPageSetup\n" (if landscape? - "page-width output-scale lily-output-units mul mul 0 translate 90 rotate\n" - "") + "page-width output-scale lily-output-units mul mul 0 translate 90 rotate\n" + "") "%%EndPageSetup\n" "\n" "true setstrokeadjust\n" @@ -105,77 +105,77 @@ (define (supplies-or-needs paper load-fonts?) (define (extract-names font) (if (ly:pango-font? font) - (map car (ly:pango-font-physical-fonts font)) - (list (ly:font-name font)))) + (map car (ly:pango-font-physical-fonts font)) + (list (ly:font-name font)))) (let* ((fonts (ly:paper-fonts paper)) - (names (apply append (map extract-names fonts)))) + (names (apply append (map extract-names fonts)))) (apply string-append - (map (lambda (f) - (format #f - (if load-fonts? - "%%DocumentSuppliedResources: font ~a\n" - "%%DocumentNeededResources: font ~a\n") - f)) - (uniq-list (sort names string<?)))))) + (map (lambda (f) + (format #f + (if load-fonts? + "%%DocumentSuppliedResources: font ~a\n" + "%%DocumentNeededResources: font ~a\n") + f)) + (uniq-list (sort names string<?)))))) (define (eps-header paper bbox load-fonts?) (string-append "%!PS-Adobe-2.0 EPSF-2.0\n" - "%%Creator: LilyPond " (lilypond-version) "\n" - "%%BoundingBox: " - (string-join (map ly:number->string bbox) " ") "\n" - "%%Orientation: " - (if (eq? (ly:output-def-lookup paper 'landscape) #t) - "Landscape\n" - "Portrait\n") - (supplies-or-needs paper load-fonts?) - "%%EndComments\n")) + "%%Creator: LilyPond " (lilypond-version) "\n" + "%%BoundingBox: " + (string-join (map ly:number->string bbox) " ") "\n" + "%%Orientation: " + (if (eq? (ly:output-def-lookup paper 'landscape) #t) + "Landscape\n" + "Portrait\n") + (supplies-or-needs paper load-fonts?) + "%%EndComments\n")) (define (ps-document-media paper) (let* ((w (/ (* - (ly:output-def-lookup paper 'output-scale) - (ly:output-def-lookup paper 'paper-width)) (ly:bp 1))) - (h (/ (* - (ly:output-def-lookup paper 'paper-height) - (ly:output-def-lookup paper 'output-scale)) - (ly:bp 1))) - (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t))) + (ly:output-def-lookup paper 'output-scale) + (ly:output-def-lookup paper 'paper-width)) (ly:bp 1))) + (h (/ (* + (ly:output-def-lookup paper 'paper-height) + (ly:output-def-lookup paper 'output-scale)) + (ly:bp 1))) + (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t))) (ly:format "%%DocumentMedia: ~a ~2f ~2f ~a ~a ~a\n" - (ly:output-def-lookup paper 'papersizename) - (if landscape? h w) - (if landscape? w h) - 80 ;; weight - "()" ;; color - "()" ;; type - ))) + (ly:output-def-lookup paper 'papersizename) + (if landscape? h w) + (if landscape? w h) + 80 ;; weight + "()" ;; color + "()" ;; type + ))) (define (file-header paper page-count load-fonts?) (string-append "%!PS-Adobe-3.0\n" - "%%Creator: LilyPond " (lilypond-version) "\n" - "%%Pages: " (number->string page-count) "\n" - "%%PageOrder: Ascend\n" - "%%Orientation: " - (if (eq? (ly:output-def-lookup paper 'landscape) #t) - "Landscape\n" - "Portrait\n") - (ps-document-media paper) - (supplies-or-needs paper load-fonts?) - "%%EndComments\n")) + "%%Creator: LilyPond " (lilypond-version) "\n" + "%%Pages: " (number->string page-count) "\n" + "%%PageOrder: Ascend\n" + "%%Orientation: " + (if (eq? (ly:output-def-lookup paper 'landscape) #t) + "Landscape\n" + "Portrait\n") + (ps-document-media paper) + (supplies-or-needs paper load-fonts?) + "%%EndComments\n")) (define (procset file-name) (format #f - "%%BeginResource: procset (~a) 1 0 + "%%BeginResource: procset (~a) 1 0 ~a %%EndResource " - file-name (cached-file-contents file-name))) + file-name (cached-file-contents file-name))) (define (embed-document file-name) (format #f "%%BeginDocument: ~a ~a %%EndDocument " - file-name (cached-file-contents file-name))) + file-name (cached-file-contents file-name))) (define (setup-variables paper) (string-append @@ -189,12 +189,12 @@ (define-public (ps-embed-cff body font-set-name version) (let* ((binary-data - (string-append - (format #f "/~a ~s StartData " font-set-name (string-length body)) - body)) - (header - (format #f - "%%BeginResource: font ~a + (string-append + (format #f "/~a ~s StartData " font-set-name (string-length body)) + body)) + (header + (format #f + "%%BeginResource: font ~a %!PS-Adobe-3.0 Resource-FontSet %%DocumentNeededResources: ProcSet (FontSetInit) %%Title: (FontSet/~a) @@ -205,70 +205,70 @@ /FontSetInit /ProcSet findresource begin %%BeginData: ~s Binary Bytes " - font-set-name font-set-name version font-set-name - (string-length binary-data))) - (footer "\n%%EndData + font-set-name font-set-name version font-set-name + (string-length binary-data))) + (footer "\n%%EndData %%EndResource %%EndResource\n")) (string-append header - binary-data - footer))) + binary-data + footer))) (define (write-preamble paper load-fonts? port) (define (internal-font? file-name) (or (string-startswith file-name "Emmentaler") - (string-startswith file-name "emmentaler") - )) + (string-startswith file-name "emmentaler") + )) (define (load-font-via-GS font-name-filename) (define (ps-load-file file-name) (if (string? file-name) - (if (string-contains file-name (ly:get-option 'datadir)) - (begin - (set! file-name (ly:string-substitute (ly:get-option 'datadir) - "" file-name)) - (format #f - "lilypond-datadir (~a) concatstrings (r) file .loadfont\n" - file-name)) - (format #f "(~a) (r) file .loadfont\n" file-name)) - (format #f "% cannot find font file: ~a\n" file-name))) + (if (string-contains file-name (ly:get-option 'datadir)) + (begin + (set! file-name (ly:string-substitute (ly:get-option 'datadir) + "" file-name)) + (format #f + "lilypond-datadir (~a) concatstrings (r) file .loadfont\n" + file-name)) + (format #f "(~a) (r) file .loadfont\n" file-name)) + (format #f "% cannot find font file: ~a\n" file-name))) (let* ((font (car font-name-filename)) - (name (cadr font-name-filename)) - (file-name (caddr font-name-filename)) - (bare-file-name (ly:find-file file-name))) + (name (cadr font-name-filename)) + (file-name (caddr font-name-filename)) + (bare-file-name (ly:find-file file-name))) (cons name - (if (mac-font? bare-file-name) - (handle-mac-font name bare-file-name) - (cond - ((internal-font? file-name) - (ps-load-file (ly:find-file - (format #f "~a.otf" file-name)))) - ((string? bare-file-name) - (ps-load-file file-name)) - (else - (ly:warning (_ "cannot embed ~S=~S") name file-name) - "")))))) + (if (mac-font? bare-file-name) + (handle-mac-font name bare-file-name) + (cond + ((internal-font? file-name) + (ps-load-file (ly:find-file + (format #f "~a.otf" file-name)))) + ((string? bare-file-name) + (ps-load-file file-name)) + (else + (ly:warning (_ "cannot embed ~S=~S") name file-name) + "")))))) (define (dir-join a b) (if (equal? a "") - b - (string-append a "/" b))) + b + (string-append a "/" b))) (define (dir-listing dir-name) (define (dir-helper dir lst) (let ((e (readdir dir))) - (if (eof-object? e) - lst - (dir-helper dir (cons e lst))))) + (if (eof-object? e) + lst + (dir-helper dir (cons e lst))))) (reverse (dir-helper (opendir dir-name) '()))) (define (handle-mac-font name file-name) (let* ((dir-name (tmpnam)) - (files '()) - (status 0) - (embed #f) - (cwd (getcwd))) + (files '()) + (status 0) + (embed #f) + (cwd (getcwd))) (mkdir dir-name #o700) (chdir dir-name) (set! status (ly:system (list "fondu" "-force" file-name))) @@ -276,107 +276,107 @@ (set! files (dir-listing dir-name)) (for-each (lambda (f) - (let* ((full-name (dir-join dir-name f))) - (if (and (not embed) - (equal? 'regular (stat:type (stat full-name))) - (equal? name (ly:ttf-ps-name full-name))) - (set! embed (font-file-as-ps-string name full-name 0))) - (if (or (equal? "." f) - (equal? ".." f)) - #t - (delete-file full-name)))) + (let* ((full-name (dir-join dir-name f))) + (if (and (not embed) + (equal? 'regular (stat:type (stat full-name))) + (equal? name (ly:ttf-ps-name full-name))) + (set! embed (font-file-as-ps-string name full-name 0))) + (if (or (equal? "." f) + (equal? ".." f)) + #t + (delete-file full-name)))) files) (rmdir dir-name) (if (not embed) - (begin - (set! embed "% failed\n") - (ly:warning (_ "cannot extract file matching ~a from ~a") - name file-name))) + (begin + (set! embed "% failed\n") + (ly:warning (_ "cannot extract file matching ~a from ~a") + name file-name))) embed)) (define (font-file-as-ps-string name file-name font-index) (let* ((downcase-file-name (string-downcase file-name))) (cond ((and file-name (string-endswith downcase-file-name ".pfa")) - (embed-document file-name)) + (embed-document file-name)) ((and file-name (string-endswith downcase-file-name ".pfb")) - (ly:pfb->pfa file-name)) + (ly:pfb->pfa file-name)) ((and file-name (string-endswith downcase-file-name ".ttf")) - (ly:ttf->pfa file-name)) + (ly:ttf->pfa file-name)) ((and file-name (string-endswith downcase-file-name ".ttc")) - (ly:ttf->pfa file-name font-index)) + (ly:ttf->pfa file-name font-index)) ((and file-name (string-endswith downcase-file-name ".otf")) - (ps-embed-cff (ly:otf->cff file-name) name 0)) + (ps-embed-cff (ly:otf->cff file-name) name 0)) (else - (ly:warning (_ "do not know how to embed ~S=~S") name file-name) - "")))) + (ly:warning (_ "do not know how to embed ~S=~S") name file-name) + "")))) (define (mac-font? bare-file-name) (and (eq? PLATFORM 'darwin) - bare-file-name - (or (string-endswith bare-file-name ".dfont") - (= (stat:size (stat bare-file-name)) 0)))) + bare-file-name + (or (string-endswith bare-file-name ".dfont") + (= (stat:size (stat bare-file-name)) 0)))) (define (load-font font-psname-filename-fontindex) (let* ((font (list-ref font-psname-filename-fontindex 0)) - (name (list-ref font-psname-filename-fontindex 1)) - (file-name (list-ref font-psname-filename-fontindex 2)) - (font-index (list-ref font-psname-filename-fontindex 3)) - (bare-file-name (ly:find-file file-name))) + (name (list-ref font-psname-filename-fontindex 1)) + (file-name (list-ref font-psname-filename-fontindex 2)) + (font-index (list-ref font-psname-filename-fontindex 3)) + (bare-file-name (ly:find-file file-name))) (cons name - (cond ((mac-font? bare-file-name) - (handle-mac-font name bare-file-name)) - ((and font (cff-font? font)) - (ps-embed-cff (ly:otf-font-table-data font "CFF ") - name - 0)) - (bare-file-name (font-file-as-ps-string - name bare-file-name font-index)) - (else - (ly:warning (_ "do not know how to embed font ~s ~s ~s") - name file-name font)))))) + (cond ((mac-font? bare-file-name) + (handle-mac-font name bare-file-name)) + ((and font (cff-font? font)) + (ps-embed-cff (ly:otf-font-table-data font "CFF ") + name + 0)) + (bare-file-name (font-file-as-ps-string + name bare-file-name font-index)) + (else + (ly:warning (_ "do not know how to embed font ~s ~s ~s") + name file-name font)))))) (define (load-fonts paper) (let* ((fonts (ly:paper-fonts paper)) - ;; todo - doc format of list. - (all-font-names - (map - (lambda (font) - (cond ((string? (ly:font-file-name font)) - (list (list font - (ly:font-name font) - (ly:font-file-name font) - #f))) - ((ly:pango-font? font) - (map (lambda (psname-filename-fontindex) - (list #f - (list-ref psname-filename-fontindex 0) - (list-ref psname-filename-fontindex 1) - (list-ref psname-filename-fontindex 2))) - (ly:pango-font-physical-fonts font))) - (else - (ly:font-sub-fonts font)))) - fonts)) - (font-names (uniq-list - (sort (apply append all-font-names) - (lambda (x y) (string<? (cadr x) (cadr y)))))) - - ;; slightly spaghetti-ish: deciding what to load where - ;; is smeared out. - (font-loader - (lambda (name) - (cond ((ly:get-option 'gs-load-fonts) - (load-font-via-GS name)) - ((ly:get-option 'gs-load-lily-fonts) - (if (or (string-contains (caddr name) - (ly:get-option 'datadir)) - (internal-font? (caddr name))) - (load-font-via-GS name) - (load-font name))) - (else - (load-font name))))) - (pfas (map font-loader font-names))) + ;; todo - doc format of list. + (all-font-names + (map + (lambda (font) + (cond ((string? (ly:font-file-name font)) + (list (list font + (ly:font-name font) + (ly:font-file-name font) + #f))) + ((ly:pango-font? font) + (map (lambda (psname-filename-fontindex) + (list #f + (list-ref psname-filename-fontindex 0) + (list-ref psname-filename-fontindex 1) + (list-ref psname-filename-fontindex 2))) + (ly:pango-font-physical-fonts font))) + (else + (ly:font-sub-fonts font)))) + fonts)) + (font-names (uniq-list + (sort (apply append all-font-names) + (lambda (x y) (string<? (cadr x) (cadr y)))))) + + ;; slightly spaghetti-ish: deciding what to load where + ;; is smeared out. + (font-loader + (lambda (name) + (cond ((ly:get-option 'gs-load-fonts) + (load-font-via-GS name)) + ((ly:get-option 'gs-load-lily-fonts) + (if (or (string-contains (caddr name) + (ly:get-option 'datadir)) + (internal-font? (caddr name))) + (load-font-via-GS name) + (load-font name))) + (else + (load-font name))))) + (pfas (map font-loader font-names))) pfas)) @@ -387,10 +387,10 @@ (ly:get-option 'datadir)) (if load-fonts? (for-each (lambda (f) - (format port "\n%%BeginFont: ~a\n" (car f)) - (display (cdr f) port) - (display "%%EndFont\n" port)) - (load-fonts paper))) + (format port "\n%%BeginFont: ~a\n" (car f)) + (display (cdr f) port) + (display "%%EndFont\n" port)) + (load-fonts paper))) (display (setup-variables paper) port) ;; adobe note 5002: should initialize variables before loading routines. @@ -400,15 +400,15 @@ (display "%%BeginSetup\ninit-lilypond-parameters\n%%EndSetup\n\n" port)) (define (ps-quote str) - (fold - (lambda (replacement-list result) - (string-join - (string-split - result - (car replacement-list)) - (cadr replacement-list))) - str - '((#\\ "\\\\") (#\( "\\(") (#\) "\\)")))) + (fold + (lambda (replacement-list result) + (string-join + (string-split + result + (car replacement-list)) + (cadr replacement-list))) + str + '((#\\ "\\\\") (#\( "\\(") (#\) "\\)")))) ;;; Create DOCINFO pdfmark containing metadata ;;; header fields with pdf prefix override those without the prefix @@ -421,10 +421,10 @@ (ps-quote (ly:encode-string-for-pdf val))) (define (metadata-lookup-output overridevar fallbackvar field) (let* ((overrideval (ly:modules-lookup (list header) overridevar)) - (fallbackval (ly:modules-lookup (list header) fallbackvar)) - (val (if overrideval overrideval fallbackval))) + (fallbackval (ly:modules-lookup (list header) fallbackvar)) + (val (if overrideval overrideval fallbackval))) (if val - (format port "/~a (~a)\n" field (metadata-encode (markup->string val (list header))))))) + (format port "/~a (~a)\n" field (metadata-encode (markup->string val (list header))))))) (display "[ " port) (metadata-lookup-output 'pdfcomposer 'composer "Author") (format port "/Creator (LilyPond ~a)\n" (lilypond-version)) @@ -442,31 +442,31 @@ (define-public (output-framework basename book scopes fields) (let* ((filename (format #f "~a.ps" basename)) - (outputter (ly:make-paper-outputter - ;; FIXME: better wrap open/open-file, - ;; content-mangling is always bad. - ;; MINGW hack: need to have "b"inary for embedding CFFs - (open-file filename "wb") - 'ps)) - (paper (ly:paper-book-paper book)) - (header (ly:paper-book-header book)) - (systems (ly:paper-book-systems book)) - (page-stencils (map page-stencil (ly:paper-book-pages book))) - (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t)) - (page-number (1- (ly:output-def-lookup paper 'first-page-number))) - (page-count (length page-stencils)) - (port (ly:outputter-port outputter))) + (outputter (ly:make-paper-outputter + ;; FIXME: better wrap open/open-file, + ;; content-mangling is always bad. + ;; MINGW hack: need to have "b"inary for embedding CFFs + (open-file filename "wb") + 'ps)) + (paper (ly:paper-book-paper book)) + (header (ly:paper-book-header book)) + (systems (ly:paper-book-systems book)) + (page-stencils (map page-stencil (ly:paper-book-pages book))) + (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t)) + (page-number (1- (ly:output-def-lookup paper 'first-page-number))) + (page-count (length page-stencils)) + (port (ly:outputter-port outputter))) (if (ly:get-option 'clip-systems) - (clip-system-EPSes basename book)) + (clip-system-EPSes basename book)) (if (ly:get-option 'dump-signatures) - (write-system-signatures basename (ly:paper-book-systems book) 1)) + (write-system-signatures basename (ly:paper-book-systems book) 1)) (output-scopes scopes fields basename) (display (file-header paper page-count #t) port) ;; don't do BeginDefaults PageMedia: A4 ;; not necessary and wrong (write-preamble paper #t port) (if (module? header) - (handle-metadata header port)) + (handle-metadata header port)) (for-each (lambda (page) (set! page-number (1+ page-number)) @@ -475,68 +475,68 @@ (display "%%Trailer\n%%EOF\n" port) (ly:outputter-close outputter) (postprocess-output book framework-ps-module filename - (ly:output-formats)))) + (ly:output-formats)))) (define-public (dump-stencil-as-EPS paper dump-me filename - load-fonts) + load-fonts) (let* ((xext (ly:stencil-extent dump-me X)) - (yext (ly:stencil-extent dump-me Y)) - (padding (ly:get-option 'eps-box-padding)) - (left-overshoot (if (number? padding) - (* -1 padding (ly:output-def-lookup paper 'mm)) - #f)) - (bbox - (map - (lambda (x) - (if (or (nan? x) (inf? x) - ;; FIXME: huh? - (equal? (format #f "~S" x) "+#.#") - (equal? (format #f "~S" x) "-#.#")) - 0.0 x)) - - ;; the left-overshoot is to make sure that - ;; bar numbers stick out of margin uniformly. - ;; - (list - (if (number? left-overshoot) - (min left-overshoot (car xext)) - (car xext)) - (car yext) (cdr xext) (cdr yext))))) + (yext (ly:stencil-extent dump-me Y)) + (padding (ly:get-option 'eps-box-padding)) + (left-overshoot (if (number? padding) + (* -1 padding (ly:output-def-lookup paper 'mm)) + #f)) + (bbox + (map + (lambda (x) + (if (or (nan? x) (inf? x) + ;; FIXME: huh? + (equal? (format #f "~S" x) "+#.#") + (equal? (format #f "~S" x) "-#.#")) + 0.0 x)) + + ;; the left-overshoot is to make sure that + ;; bar numbers stick out of margin uniformly. + ;; + (list + (if (number? left-overshoot) + (min left-overshoot (car xext)) + (car xext)) + (car yext) (cdr xext) (cdr yext))))) (dump-stencil-as-EPS-with-bbox paper dump-me filename load-fonts bbox))) (define-public (dump-stencil-as-EPS-with-bbox paper dump-me filename - load-fonts - bbox) + load-fonts + bbox) "Create an EPS file from stencil @var{dump-me} to @var{filename}. @var{bbox} has format @code{(left-x, lower-y, right-x, upper-y)}. If @var{load-fonts} set, include fonts inline." (define (to-rounded-bp-box box) "Convert box to 1/72 inch with rounding to enlarge the box." (let* ((scale (ly:output-def-lookup paper 'output-scale)) - (strip-non-number (lambda (x) - (if (or (nan? x) - (inf? x)) - 0.0 - x))) - (directed-round (lambda (x rounder) - (inexact->exact - (rounder (/ (* (strip-non-number x) scale) - (ly:bp 1))))))) + (strip-non-number (lambda (x) + (if (or (nan? x) + (inf? x)) + 0.0 + x))) + (directed-round (lambda (x rounder) + (inexact->exact + (rounder (/ (* (strip-non-number x) scale) + (ly:bp 1))))))) (list (directed-round (car box) floor) - (directed-round (cadr box) floor) - (directed-round (max (1+ (car box)) (caddr box)) ceiling) - (directed-round (max (1+ (cadr box)) (cadddr box)) ceiling)))) + (directed-round (cadr box) floor) + (directed-round (max (1+ (car box)) (caddr box)) ceiling) + (directed-round (max (1+ (cadr box)) (cadddr box)) ceiling)))) (let* ((outputter (ly:make-paper-outputter - ;; FIXME: better wrap open/open-file, - ;; content-mangling is always bad. - ;; MINGW hack: need to have "b"inary for embedding CFFs - (open-file (format #f "~a.eps" filename) "wb") - 'ps)) - (port (ly:outputter-port outputter)) - (rounded-bbox (to-rounded-bp-box bbox)) - (port (ly:outputter-port outputter)) - (header (eps-header paper rounded-bbox load-fonts))) + ;; FIXME: better wrap open/open-file, + ;; content-mangling is always bad. + ;; MINGW hack: need to have "b"inary for embedding CFFs + (open-file (format #f "~a.eps" filename) "wb") + 'ps)) + (port (ly:outputter-port outputter)) + (rounded-bbox (to-rounded-bp-box bbox)) + (port (ly:outputter-port outputter)) + (header (eps-header paper rounded-bbox load-fonts))) (display header port) (write-preamble paper load-fonts port) (display "gsave set-ps-scale-to-lily-scale\n" port) @@ -546,36 +546,36 @@ (define (clip-systems-to-region basename paper systems region do-pdf do-png) (let* ((extents-system-pairs - (filtered-map (lambda (paper-system) - (let* ((x-ext (system-clipped-x-extent - (paper-system-system-grob paper-system) - region))) - (if x-ext - (cons x-ext paper-system) - #f))) - systems)) - (count 0)) + (filtered-map (lambda (paper-system) + (let* ((x-ext (system-clipped-x-extent + (paper-system-system-grob paper-system) + region))) + (if x-ext + (cons x-ext paper-system) + #f))) + systems)) + (count 0)) (for-each (lambda (ext-system-pair) (let* ((xext (car ext-system-pair)) - (paper-system (cdr ext-system-pair)) - (yext (paper-system-extent paper-system Y)) - (bbox (list (car xext) (car yext) - (cdr xext) (cdr yext))) - (filename (if (< 0 count) - (format #f "~a-~a" basename count) - basename))) - (set! count (1+ count)) - (dump-stencil-as-EPS-with-bbox paper - (paper-system-stencil paper-system) - filename - (ly:get-option 'include-eps-fonts) - bbox) - (if do-pdf - (postscript->pdf 0 0 (format #f "~a.eps" filename))) - (if do-png - (postscript->png (ly:get-option 'resolution) 0 0 - (format #f "~a.eps" filename))))) + (paper-system (cdr ext-system-pair)) + (yext (paper-system-extent paper-system Y)) + (bbox (list (car xext) (car yext) + (cdr xext) (cdr yext))) + (filename (if (< 0 count) + (format #f "~a-~a" basename count) + basename))) + (set! count (1+ count)) + (dump-stencil-as-EPS-with-bbox paper + (paper-system-stencil paper-system) + filename + (ly:get-option 'include-eps-fonts) + bbox) + (if do-pdf + (postscript->pdf 0 0 (format #f "~a.eps" filename))) + (if do-png + (postscript->png (ly:get-option 'resolution) 0 0 + (format #f "~a.eps" filename))))) extents-system-pairs))) (define-public (clip-system-EPSes basename paper-book) @@ -586,76 +586,76 @@ (define (clip-score-systems basename systems) (let* ((layout (ly:grob-layout (paper-system-system-grob (car systems)))) - (regions (ly:output-def-lookup layout 'clip-regions))) + (regions (ly:output-def-lookup layout 'clip-regions))) (for-each (lambda (region) - (clip-systems-to-region - (format #f "~a-from-~a-to-~a-clip" - basename - (rhythmic-location->file-string (car region)) - (rhythmic-location->file-string (cdr region))) - layout systems region - do-pdf do-png)) + (clip-systems-to-region + (format #f "~a-from-~a-to-~a-clip" + basename + (rhythmic-location->file-string (car region)) + (rhythmic-location->file-string (cdr region))) + layout systems region + do-pdf do-png)) regions))) ;; partition in system lists sharing their layout blocks (let* ((systems (ly:paper-book-systems paper-book)) - (count 0) - (score-system-list '())) + (count 0) + (score-system-list '())) (fold (lambda (system last-system) (if (not (and last-system - (equal? (paper-system-layout last-system) - (paper-system-layout system)))) - (set! score-system-list (cons '() score-system-list))) + (equal? (paper-system-layout last-system) + (paper-system-layout system)))) + (set! score-system-list (cons '() score-system-list))) (if (paper-system-layout system) - (set-car! score-system-list (cons system (car score-system-list)))) + (set-car! score-system-list (cons system (car score-system-list)))) ;; pass value. system) #f systems) (for-each (lambda (system-list) - ;; filter out headers and top-level markup - (if (pair? system-list) - (clip-score-systems - (if (> count 0) - (format #f "~a-~a" basename count) - basename) - system-list))) - score-system-list))) + ;; filter out headers and top-level markup + (if (pair? system-list) + (clip-score-systems + (if (> count 0) + (format #f "~a-~a" basename count) + basename) + system-list))) + score-system-list))) (define-public (output-preview-framework basename book scopes fields) (let* ((paper (ly:paper-book-paper book)) - (systems (relevant-book-systems book)) - (to-dump-systems (relevant-dump-systems systems))) + (systems (relevant-book-systems book)) + (to-dump-systems (relevant-dump-systems systems))) (dump-stencil-as-EPS paper - (stack-stencils Y DOWN 0.0 - (map paper-system-stencil - (reverse to-dump-systems))) - (format #f "~a.preview" basename) - #t) + (stack-stencils Y DOWN 0.0 + (map paper-system-stencil + (reverse to-dump-systems))) + (format #f "~a.preview" basename) + #t) (postprocess-output book framework-ps-module - (format #f "~a.preview.eps" basename) - (cons "png" (ly:output-formats))))) + (format #f "~a.preview.eps" basename) + (cons "png" (ly:output-formats))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (output-width-height defs) (let* ((landscape (ly:output-def-lookup defs 'landscape)) - (output-scale (ly:output-def-lookup defs 'output-scale)) - (convert (lambda (x) - (* x output-scale (/ (ly:bp 1))))) - (paper-width (convert (ly:output-def-lookup defs 'paper-width))) - (paper-height (convert (ly:output-def-lookup defs 'paper-height))) - (w (if landscape paper-height paper-width)) - (h (if landscape paper-width paper-height))) + (output-scale (ly:output-def-lookup defs 'output-scale)) + (convert (lambda (x) + (* x output-scale (/ (ly:bp 1))))) + (paper-width (convert (ly:output-def-lookup defs 'paper-width))) + (paper-height (convert (ly:output-def-lookup defs 'paper-height))) + (w (if landscape paper-height paper-width)) + (h (if landscape paper-width paper-height))) (cons w h))) (define (output-resolution defs) (let ((defs-resolution (ly:output-def-lookup defs 'pngresolution))) (if (number? defs-resolution) - defs-resolution - (ly:get-option 'resolution)))) + defs-resolution + (ly:get-option 'resolution)))) (define (output-filename name) (if (equal? (basename name ".ps") "-") @@ -664,19 +664,19 @@ (define-public (convert-to-pdf book name) (let* ((defs (ly:paper-book-paper book)) - (width-height (output-width-height defs)) - (width (car width-height)) - (height (cdr width-height)) - (filename (output-filename name))) + (width-height (output-width-height defs)) + (width (car width-height)) + (height (cdr width-height)) + (filename (output-filename name))) (postscript->pdf width height filename))) (define-public (convert-to-png book name) (let* ((defs (ly:paper-book-paper book)) - (resolution (output-resolution defs)) - (width-height (output-width-height defs)) - (width (car width-height)) - (height (cdr width-height)) - (filename (output-filename name))) + (resolution (output-resolution defs)) + (width-height (output-width-height defs)) + (width (car width-height)) + (height (cdr width-height)) + (filename (output-filename name))) (postscript->png resolution width height filename))) (define-public (convert-to-ps book name) diff --git a/scm/framework-scm.scm b/scm/framework-scm.scm index a47eb185fd..325ef9a0bc 100644 --- a/scm/framework-scm.scm +++ b/scm/framework-scm.scm @@ -3,31 +3,31 @@ (define-module (scm framework-scm)) (use-modules - (ice-9 regex) - (ice-9 string-fun) - (guile) - (srfi srfi-1) - (ice-9 pretty-print) - (srfi srfi-13) - (scm page) - (lily)) + (ice-9 regex) + (ice-9 string-fun) + (guile) + (srfi srfi-1) + (ice-9 pretty-print) + (srfi srfi-13) + (scm page) + (lily)) (define format ergonomic-simple-format) (define-public (output-framework basename book scopes fields) (let* ((file (open-output-file (format #f "~a.scm" basename)))) - + (display ";;Creator: LilyPond\n" file) (display ";; raw SCM output\n" file) - + (for-each - (lambda (page) - (display ";;;;;;;;;;;;;;;;;;;;;;;;;;\n;;;PAGE\n" file) - ;; The following two lines are alternates - ;(pretty-print (ly:stencil-expr page) file) - (write (ly:stencil-expr page) file) - ) - (map page-stencil (ly:paper-book-pages book))))) + (lambda (page) + (display ";;;;;;;;;;;;;;;;;;;;;;;;;;\n;;;PAGE\n" file) + ;; The following two lines are alternates + ;(pretty-print (ly:stencil-expr page) file) + (write (ly:stencil-expr page) file) + ) + (map page-stencil (ly:paper-book-pages book))))) (define-public output-classic-framework output-framework) diff --git a/scm/framework-socket.scm b/scm/framework-socket.scm index dd54293555..3eaf4710d1 100644 --- a/scm/framework-socket.scm +++ b/scm/framework-socket.scm @@ -5,72 +5,72 @@ ) (use-modules (ice-9 regex) - (ice-9 string-fun) - (scm paper-system) - (ice-9 format) - (guile) - (srfi srfi-1) - (ice-9 pretty-print) - (srfi srfi-13) - (lily)) + (ice-9 string-fun) + (scm paper-system) + (ice-9 format) + (guile) + (srfi srfi-1) + (ice-9 pretty-print) + (srfi srfi-13) + (lily)) (define (get-page-dimensions paper) (let* ((landscape (ly:output-def-lookup paper 'landscape)) - (output-scale (ly:output-def-lookup paper 'output-scale)) - (paper-width (ly:output-def-lookup paper 'paper-width)) - (paper-height (ly:output-def-lookup paper 'paper-height)) - (indent (ly:output-def-lookup paper 'indent)) - (line-width (ly:output-def-lookup paper 'line-width)) - (plain-left-margin (ly:output-def-lookup paper 'left-margin)) - (top-margin (ly:output-def-lookup paper 'top-margin)) - (w (if landscape paper-height paper-width)) - (h (if landscape paper-width paper-height)) - (left-margin (if (null? plain-left-margin) - (/ (- w line-width) 2) - plain-left-margin)) -;; (list w h left-margin top-margin indent line-width))) -;; (convert (lambda (x) (* x output-scale (/ (ly:bp 1)))))) - (unit-length (ly:output-def-lookup paper 'output-scale)) - (convert (lambda (x) (* x lily-unit->mm-factor unit-length)))) + (output-scale (ly:output-def-lookup paper 'output-scale)) + (paper-width (ly:output-def-lookup paper 'paper-width)) + (paper-height (ly:output-def-lookup paper 'paper-height)) + (indent (ly:output-def-lookup paper 'indent)) + (line-width (ly:output-def-lookup paper 'line-width)) + (plain-left-margin (ly:output-def-lookup paper 'left-margin)) + (top-margin (ly:output-def-lookup paper 'top-margin)) + (w (if landscape paper-height paper-width)) + (h (if landscape paper-width paper-height)) + (left-margin (if (null? plain-left-margin) + (/ (- w line-width) 2) + plain-left-margin)) + ;; (list w h left-margin top-margin indent line-width))) + ;; (convert (lambda (x) (* x output-scale (/ (ly:bp 1)))))) + (unit-length (ly:output-def-lookup paper 'output-scale)) + (convert (lambda (x) (* x lily-unit->mm-factor unit-length)))) (map convert (list w h left-margin top-margin indent line-width)))) (define-public (output-framework channel book scopes fields) (let* ((ctor-arg (if (string? channel) - (open-output-file (format #f "~a.socket" channel)) - channel)) - (outputter (ly:make-paper-outputter - ctor-arg - 'socket)) - (systems (ly:paper-book-systems book)) - (paper (ly:paper-book-paper book)) - (pages (ly:paper-book-pages book))) + (open-output-file (format #f "~a.socket" channel)) + channel)) + (outputter (ly:make-paper-outputter + ctor-arg + 'socket)) + (systems (ly:paper-book-systems book)) + (paper (ly:paper-book-paper book)) + (pages (ly:paper-book-pages book))) (for-each (lambda (x) - (let* ((system-stencil (paper-system-stencil x)) - (x-extent (ly:stencil-extent system-stencil X)) - (y-extent (ly:stencil-extent system-stencil Y))) - (display (ly:format "system ~4l ~4l ~4l ~4l\n" - (car x-extent) (car y-extent) (cdr x-extent) (cdr y-extent)) ctor-arg) - (ly:outputter-dump-stencil outputter system-stencil))) - systems))) + (let* ((system-stencil (paper-system-stencil x)) + (x-extent (ly:stencil-extent system-stencil X)) + (y-extent (ly:stencil-extent system-stencil Y))) + (display (ly:format "system ~4l ~4l ~4l ~4l\n" + (car x-extent) (car y-extent) (cdr x-extent) (cdr y-extent)) ctor-arg) + (ly:outputter-dump-stencil outputter system-stencil))) + systems))) (define-public (output-classic-framework channel book scopes fields) (let* ((ctor-arg (if (string? channel) - (open-output-file (format #f "~a.socket" channel)) - channel)) - (outputter (ly:make-paper-outputter - ctor-arg - 'socket)) - (systems (ly:paper-book-systems book)) - (paper (ly:paper-book-paper book))) + (open-output-file (format #f "~a.socket" channel)) + channel)) + (outputter (ly:make-paper-outputter + ctor-arg + 'socket)) + (systems (ly:paper-book-systems book)) + (paper (ly:paper-book-paper book))) (display (ly:format "paper ~4l\n" (get-page-dimensions paper)) ctor-arg) (for-each (lambda (x) - (let* ((system-stencil (paper-system-stencil x)) - (x-extent (ly:stencil-extent system-stencil X)) - (y-extent (ly:stencil-extent system-stencil Y))) - (display (ly:format "system ~4l ~4l ~4l ~4l\n" - (car x-extent) (car y-extent) (cdr x-extent) (cdr y-extent)) ctor-arg) - (ly:outputter-dump-stencil outputter system-stencil))) - systems))) + (let* ((system-stencil (paper-system-stencil x)) + (x-extent (ly:stencil-extent system-stencil X)) + (y-extent (ly:stencil-extent system-stencil Y))) + (display (ly:format "system ~4l ~4l ~4l ~4l\n" + (car x-extent) (car y-extent) (cdr x-extent) (cdr y-extent)) ctor-arg) + (ly:outputter-dump-stencil outputter system-stencil))) + systems))) (define-public (convert-to-ps . args) #t) (define-public (convert-to-pdf . args) #t) diff --git a/scm/framework-svg.scm b/scm/framework-svg.scm index 84deff1b5f..dad8bfa0f7 100644 --- a/scm/framework-svg.scm +++ b/scm/framework-svg.scm @@ -32,15 +32,15 @@ (define-module (scm framework-svg)) (use-modules - (guile) - (lily) - (scm page) - (scm paper-system) - (scm output-svg) - (srfi srfi-1) - (srfi srfi-2) - (srfi srfi-13) - (ice-9 regex)) + (guile) + (lily) + (scm page) + (scm paper-system) + (scm output-svg) + (srfi srfi-1) + (srfi srfi-2) + (srfi srfi-13) + (ice-9 regex)) (define format ergonomic-simple-format) @@ -52,8 +52,8 @@ `(width . ,(ly:format "~2fmm" (first rest))) `(height . ,(ly:format "~2fmm" (second rest))) `(viewBox . ,(ly:format "~4f ~4f ~4f ~4f" - (third rest) (fourth rest) - (fifth rest) (sixth rest))))) + (third rest) (fourth rest) + (fifth rest) (sixth rest))))) (define (svg-end) (ec 'svg)) @@ -61,40 +61,40 @@ (define (mkdirs dir-name mode) (let loop ((dir-name (string-split dir-name #\/)) (root "")) (if (pair? dir-name) - (let ((dir (string-append root (car dir-name)))) - (if (not (file-exists? dir)) - (mkdir dir mode)) - (loop (cdr dir-name) (string-append dir "/")))))) - + (let ((dir (string-append root (car dir-name)))) + (if (not (file-exists? dir)) + (mkdir dir mode)) + (loop (cdr dir-name) (string-append dir "/")))))) + (define output-dir #f) (define (svg-define-font font font-name scaling) (let* ((base-file-name (basename (if (list? font) (pango-pf-file-name font) - (ly:font-file-name font)) ".otf")) - (woff-file-name (string-regexp-substitute "([.]otf)?$" ".woff" - base-file-name)) - (woff-file (or (ly:find-file woff-file-name) "/no-such-file.woff")) - (url (string-append output-dir "/fonts/" (lilypond-version) "/" - (basename woff-file-name))) - (lower-name (string-downcase font-name))) + (ly:font-file-name font)) ".otf")) + (woff-file-name (string-regexp-substitute "([.]otf)?$" ".woff" + base-file-name)) + (woff-file (or (ly:find-file woff-file-name) "/no-such-file.woff")) + (url (string-append output-dir "/fonts/" (lilypond-version) "/" + (basename woff-file-name))) + (lower-name (string-downcase font-name))) (if (file-exists? woff-file) - (begin - (if (not (file-exists? url)) - (begin - (ly:message (_ "Updating font into: ~a") url) - (mkdirs (string-append output-dir "/" (dirname url)) #o700) - (copy-file woff-file url) - (ly:progress "\n"))) - (ly:format - "@font-face { + (begin + (if (not (file-exists? url)) + (begin + (ly:message (_ "Updating font into: ~a") url) + (mkdirs (string-append output-dir "/" (dirname url)) #o700) + (copy-file woff-file url) + (ly:progress "\n"))) + (ly:format + "@font-face { font-family: '~a'; font-weight: normal; font-style: normal; src: url('~a'); } " - font-name url)) - ""))) + font-name url)) + ""))) (define (woff-header paper dir) "TODO: @@ -115,57 +115,57 @@ src: url('~a'); (define (dump-page paper filename page page-number page-count) (let* ((outputter (ly:make-paper-outputter (open-file filename "wb") 'svg)) - (dump (lambda (str) (display str (ly:outputter-port outputter)))) - (lookup (lambda (x) (ly:output-def-lookup paper x))) - (unit-length (lookup 'output-scale)) - (output-scale (* lily-unit->mm-factor unit-length)) - (device-width (lookup 'paper-width)) - (device-height (lookup 'paper-height)) - (page-width (* output-scale device-width)) - (page-height (* output-scale device-height))) + (dump (lambda (str) (display str (ly:outputter-port outputter)))) + (lookup (lambda (x) (ly:output-def-lookup paper x))) + (unit-length (lookup 'output-scale)) + (output-scale (* lily-unit->mm-factor unit-length)) + (device-width (lookup 'paper-width)) + (device-height (lookup 'paper-height)) + (page-width (* output-scale device-width)) + (page-height (* output-scale device-height))) (if (ly:get-option 'svg-woff) - (module-define! (ly:outputter-module outputter) 'paper paper)) + (module-define! (ly:outputter-module outputter) 'paper paper)) (dump (svg-begin page-width page-height - 0 0 device-width device-height)) + 0 0 device-width device-height)) (if (ly:get-option 'svg-woff) - (module-remove! (ly:outputter-module outputter) 'paper)) + (module-remove! (ly:outputter-module outputter) 'paper)) (if (ly:get-option 'svg-woff) - (dump (woff-header paper (dirname filename)))) + (dump (woff-header paper (dirname filename)))) (dump (comment (format #f "Page: ~S/~S" page-number page-count))) (ly:outputter-output-scheme outputter - `(begin (set! lily-unit-length ,unit-length) - "")) + `(begin (set! lily-unit-length ,unit-length) + "")) (ly:outputter-dump-stencil outputter page) (dump (svg-end)) (ly:outputter-close outputter))) (define (dump-preview paper stencil filename) (let* ((outputter (ly:make-paper-outputter (open-file filename "wb") 'svg)) - (dump (lambda (str) (display str (ly:outputter-port outputter)))) - (lookup (lambda (x) (ly:output-def-lookup paper x))) - (unit-length (lookup 'output-scale)) - (x-extent (ly:stencil-extent stencil X)) - (y-extent (ly:stencil-extent stencil Y)) - (left-x (car x-extent)) - (top-y (cdr y-extent)) - (device-width (interval-length x-extent)) - (device-height (interval-length y-extent)) - (output-scale (* lily-unit->mm-factor unit-length)) - (svg-width (* output-scale device-width)) - (svg-height (* output-scale device-height))) + (dump (lambda (str) (display str (ly:outputter-port outputter)))) + (lookup (lambda (x) (ly:output-def-lookup paper x))) + (unit-length (lookup 'output-scale)) + (x-extent (ly:stencil-extent stencil X)) + (y-extent (ly:stencil-extent stencil Y)) + (left-x (car x-extent)) + (top-y (cdr y-extent)) + (device-width (interval-length x-extent)) + (device-height (interval-length y-extent)) + (output-scale (* lily-unit->mm-factor unit-length)) + (svg-width (* output-scale device-width)) + (svg-height (* output-scale device-height))) (if (ly:get-option 'svg-woff) - (module-define! (ly:outputter-module outputter) 'paper paper)) + (module-define! (ly:outputter-module outputter) 'paper paper)) (dump (svg-begin svg-width svg-height - left-x (- top-y) device-width device-height)) + left-x (- top-y) device-width device-height)) (if (ly:get-option 'svg-woff) - (module-remove! (ly:outputter-module outputter) 'paper)) + (module-remove! (ly:outputter-module outputter) 'paper)) (if (ly:get-option 'svg-woff) - (dump (woff-header paper (dirname filename)))) + (dump (woff-header paper (dirname filename)))) (ly:outputter-output-scheme outputter - `(begin (set! lily-unit-length ,unit-length) - "")) + `(begin (set! lily-unit-length ,unit-length) + "")) (ly:outputter-dump-stencil outputter stencil) (dump (svg-end)) (ly:outputter-close outputter))) @@ -173,27 +173,27 @@ src: url('~a'); (define (output-framework basename book scopes fields) (let* ((paper (ly:paper-book-paper book)) - (page-stencils (map page-stencil (ly:paper-book-pages book))) - (page-number (1- (ly:output-def-lookup paper 'first-page-number))) - (page-count (length page-stencils)) - (filename "") - (file-suffix (lambda (num) - (if (= page-count 1) "" (format #f "-page-~a" num))))) + (page-stencils (map page-stencil (ly:paper-book-pages book))) + (page-number (1- (ly:output-def-lookup paper 'first-page-number))) + (page-count (length page-stencils)) + (filename "") + (file-suffix (lambda (num) + (if (= page-count 1) "" (format #f "-page-~a" num))))) (for-each - (lambda (page) - (set! page-number (1+ page-number)) - (set! filename (format #f "~a~a.svg" - basename - (file-suffix page-number))) - (dump-page paper filename page page-number page-count)) - page-stencils))) + (lambda (page) + (set! page-number (1+ page-number)) + (set! filename (format #f "~a~a.svg" + basename + (file-suffix page-number))) + (dump-page paper filename page page-number page-count)) + page-stencils))) (define (output-preview-framework basename book scopes fields) (let* ((paper (ly:paper-book-paper book)) - (systems (relevant-book-systems book)) - (to-dump-systems (relevant-dump-systems systems))) + (systems (relevant-book-systems book)) + (to-dump-systems (relevant-dump-systems systems))) (dump-preview paper - (stack-stencils Y DOWN 0.0 - (map paper-system-stencil - (reverse to-dump-systems))) - (format #f "~a.preview.svg" basename)))) + (stack-stencils Y DOWN 0.0 + (map paper-system-stencil + (reverse to-dump-systems))) + (format #f "~a.preview.svg" basename)))) diff --git a/scm/fret-diagrams.scm b/scm/fret-diagrams.scm index 7a6e6febd9..76a1801212 100644 --- a/scm/fret-diagrams.scm +++ b/scm/fret-diagrams.scm @@ -21,7 +21,7 @@ "Return the x-extent of a string that goes from start-point to end-point." (let ((x1 (car start-point)) - (x2 (car end-point))) + (x2 (car end-point))) (if (> x1 x2) (cons x2 x1) (cons x1 x2)))) @@ -30,7 +30,7 @@ to end-point." "Return the y-extent of a string that goes from start-point to end-point." (let ((y1 (cdr start-point)) - (y2 (cdr end-point))) + (y2 (cdr end-point))) (if (> y1 y2) (cons y2 y1) (cons y1 y2)))) @@ -61,8 +61,8 @@ to end-point." (* 6 (/ (log mag) (log 2)))) (define (fret-count fret-range) - "Calculate the fret count for the diagram given the range of frets in the diagram." - (1+ (- (cdr fret-range) (car fret-range)))) + "Calculate the fret count for the diagram given the range of frets in the diagram." + (1+ (- (cdr fret-range) (car fret-range)))) (define (subtract-base-fret base-fret dot-list) "Subtract @var{base-fret} from every fret in @var{dot-list}" @@ -142,32 +142,32 @@ found." (define (negate-extent extent) "Return the extent in an axis opposite to the axis of @code{extent}." - (cons (- (cdr extent)) (- (car extent)))) + (cons (- (cdr extent)) (- (car extent)))) (define (stencil-fretboard-extent stencil fretboard-axis orientation) "Return the extent of @code{stencil} in the @code{fretboard-axis} direction." (if (eq? fretboard-axis 'fret) - (cond ((eq? orientation 'landscape) - (ly:stencil-extent stencil X)) - ((eq? orientation 'opposing-landscape) - (negate-extent (ly:stencil-extent stencil X))) - (else - (negate-extent (ly:stencil-extent stencil Y)))) - ;; else -- eq? fretboard-axis 'string - (cond ((eq? orientation 'landscape) - (ly:stencil-extent stencil Y)) - ((eq? orientation 'opposing-landscape) - (negate-extent (ly:stencil-extent stencil Y))) - (else - (ly:stencil-extent stencil Y))))) + (cond ((eq? orientation 'landscape) + (ly:stencil-extent stencil X)) + ((eq? orientation 'opposing-landscape) + (negate-extent (ly:stencil-extent stencil X))) + (else + (negate-extent (ly:stencil-extent stencil Y)))) + ;; else -- eq? fretboard-axis 'string + (cond ((eq? orientation 'landscape) + (ly:stencil-extent stencil Y)) + ((eq? orientation 'opposing-landscape) + (negate-extent (ly:stencil-extent stencil Y))) + (else + (ly:stencil-extent stencil Y))))) (define (stencil-fretboard-offset stencil fretboard-axis orientation) - "Return a the stencil coordinates of the center of @code{stencil} + "Return a the stencil coordinates of the center of @code{stencil} in the @code{fretboard-axis} direction." (* 0.5 (interval-length - (stencil-fretboard-extent stencil fretboard-axis orientation)))) + (stencil-fretboard-extent stencil fretboard-axis orientation)))) (define (string-thickness string thickness-factor) @@ -187,8 +187,8 @@ with magnification @var{mag} of the string @var{text}." ;; markup commands and associated functions (define (fret-parse-marking-list marking-list my-fret-count) - "Parse a fret-diagram-verbose marking list into component sublists" - (let* ((fret-range (cons 1 my-fret-count)) + "Parse a fret-diagram-verbose marking list into component sublists" + (let* ((fret-range (cons 1 my-fret-count)) (capo-fret 0) (barre-list '()) (dot-list '()) @@ -203,7 +203,7 @@ with magnification @var{mag} of the string @var{text}." ((eq? my-code 'barre) (set! barre-list (cons* (cdr my-item) barre-list))) ((eq? my-code 'capo) - (set! capo-fret (cadr my-item))) + (set! capo-fret (cadr my-item))) ((eq? my-code 'place-fret) (set! dot-list (cons* (cdr my-item) dot-list)))) (parse-item (cdr mylist))))) @@ -243,14 +243,14 @@ with magnification @var{mag} of the string @var{text}." ;; from FretBoard engraver, but not from markup call (details (merge-details 'fret-diagram-details props '())) (string-count - (assoc-get 'string-count details 6)) ;; needed for everything + (assoc-get 'string-count details 6)) ;; needed for everything (my-fret-count - (assoc-get 'fret-count details 4)) ;; needed for everything + (assoc-get 'fret-count details 4)) ;; needed for everything (orientation - (assoc-get 'orientation details 'normal)) ;; needed for everything + (assoc-get 'orientation details 'normal)) ;; needed for everything (finger-code - (assoc-get - 'finger-code details 'none)) ;; needed for draw-dots and draw-barre + (assoc-get + 'finger-code details 'none)) ;; needed for draw-dots and draw-barre (default-dot-radius (if (eq? finger-code 'in-dot) 0.425 0.25)) ;; bigger dots if labeled (default-dot-position @@ -258,21 +258,21 @@ with magnification @var{mag} of the string @var{text}." (- 0.95 default-dot-radius) 0.6)) ; move up to make room for bigger dot if labeled (dot-radius - (assoc-get - 'dot-radius details default-dot-radius)) - ;; needed for draw-dots and draw-barre + (assoc-get + 'dot-radius details default-dot-radius)) + ;; needed for draw-dots and draw-barre (dot-position - (assoc-get - 'dot-position details default-dot-position)) - ;; needed for draw-dots and draw-barre + (assoc-get + 'dot-position details default-dot-position)) + ;; needed for draw-dots and draw-barre (th - (* (ly:output-def-lookup layout 'line-thickness) - (chain-assoc-get 'thickness props 0.5))) - ;; needed for draw-frets and draw-strings + (* (ly:output-def-lookup layout 'line-thickness) + (chain-assoc-get 'thickness props 0.5))) + ;; needed for draw-frets and draw-strings (sth (* size th)) (thickness-factor (assoc-get 'string-thickness-factor details 0)) (alignment - (chain-assoc-get 'align-dir props -0.4)) ;; needed only here + (chain-assoc-get 'align-dir props -0.4)) ;; needed only here (xo-padding (assoc-get 'xo-padding details 0.2)) ;; needed only here (parameters (fret-parse-marking-list marking-list my-fret-count)) (capo-fret (assoc-get 'capo-fret parameters 0)) @@ -282,7 +282,7 @@ with magnification @var{mag} of the string @var{text}." (my-fret-count (fret-count fret-range)) (barre-list (assoc-get 'barre-list parameters)) (barre-type - (assoc-get 'barre-type details 'curved)) + (assoc-get 'barre-type details 'curved)) (fret-diagram-stencil '())) ;; Here are the fret diagram helper functions that depend on the @@ -293,24 +293,24 @@ with magnification @var{mag} of the string @var{text}." "Return a pair @code{(x-coordinate . y-coordinate)} in stencil coordinate system." (cond - ((eq? orientation 'landscape) - (cons fret-coordinate - (- string-coordinate (1- string-count)))) - ((eq? orientation 'opposing-landscape) - (cons (- fret-coordinate) (- string-coordinate))) - (else - (cons string-coordinate (- fret-coordinate))))) + ((eq? orientation 'landscape) + (cons fret-coordinate + (- string-coordinate (1- string-count)))) + ((eq? orientation 'opposing-landscape) + (cons (- fret-coordinate) (- string-coordinate))) + (else + (cons string-coordinate (- fret-coordinate))))) (define (stencil-coordinate-offset fret-offset string-offset) "Return a pair @code{(x-offset . y-offset)} for translation in stencil coordinate system." (cond - ((eq? orientation 'landscape) - (cons fret-offset (- string-offset))) - ((eq? orientation 'opposing-landscape) - (cons (- fret-offset) string-offset)) - (else - (cons string-offset (- fret-offset))))) + ((eq? orientation 'landscape) + (cons fret-offset (- string-offset))) + ((eq? orientation 'opposing-landscape) + (cons (- fret-offset) string-offset)) + (else + (cons string-offset (- fret-offset))))) @@ -320,42 +320,42 @@ with magnification @var{mag} of the string @var{text}." string coordinate @var{start} to string-coordinate @var{stop} with a baseline at fret coordinate @var{base}, a height of @var{height}, and a half thickness of @var{half-thickness}." - (let* ((width (+ (- stop start) 1)) - (cp-left-width (+ (* width half-thickness) start)) - (cp-right-width (- stop (* width half-thickness))) - (bottom-control-point-height - (- base (- height half-thickness))) - (top-control-point-height - (- base height)) - (left-end-point - (stencil-coordinates base start)) - (right-end-point - (stencil-coordinates base stop)) - (left-upper-control-point - (stencil-coordinates + (let* ((width (+ (- stop start) 1)) + (cp-left-width (+ (* width half-thickness) start)) + (cp-right-width (- stop (* width half-thickness))) + (bottom-control-point-height + (- base (- height half-thickness))) + (top-control-point-height + (- base height)) + (left-end-point + (stencil-coordinates base start)) + (right-end-point + (stencil-coordinates base stop)) + (left-upper-control-point + (stencil-coordinates top-control-point-height cp-left-width)) - (left-lower-control-point - (stencil-coordinates + (left-lower-control-point + (stencil-coordinates bottom-control-point-height cp-left-width)) - (right-upper-control-point - (stencil-coordinates + (right-upper-control-point + (stencil-coordinates top-control-point-height cp-right-width)) - (right-lower-control-point - (stencil-coordinates + (right-lower-control-point + (stencil-coordinates bottom-control-point-height cp-right-width))) - ;; order of bezier control points is: - ;; left cp low, right cp low, right end low, left end low - ;; right cp high, left cp high, left end high, right end high. + ;; order of bezier control points is: + ;; left cp low, right cp low, right end low, left end low + ;; right cp high, left cp high, left end high, right end high. - (list left-lower-control-point - right-lower-control-point - right-end-point - left-end-point - right-upper-control-point - left-upper-control-point - left-end-point - right-end-point))) + (list left-lower-control-point + right-lower-control-point + right-end-point + left-end-point + right-upper-control-point + left-upper-control-point + left-end-point + right-end-point))) (define (draw-strings) "Draw the string lines for a fret diagram with @@ -365,10 +365,10 @@ Line thickness is given by @var{th}, fret & string spacing by (define (helper x) (if (null? (cdr x)) - (string-stencil (car x)) - (ly:stencil-add (string-stencil (car x)) - (helper (cdr x))))) + (ly:stencil-add + (string-stencil (car x)) + (helper (cdr x))))) (let* ( (string-list (map 1+ (iota string-count)))) (helper string-list))) @@ -378,17 +378,17 @@ Line thickness is given by @var{th}, fret & string spacing by overall parameters." (let* ((string-coordinate (- string-count string)) (current-string-thickness - (* th size (string-thickness string thickness-factor))) + (* th size (string-thickness string thickness-factor))) (fret-half-thickness (* size th 0.5)) (half-string (* current-string-thickness 0.5)) (start-coordinates - (stencil-coordinates - (- fret-half-thickness) - (- (* size string-coordinate) half-string))) + (stencil-coordinates + (- fret-half-thickness) + (- (* size string-coordinate) half-string))) (end-coordinates - (stencil-coordinates - (+ fret-half-thickness (* size (1+ (fret-count fret-range)))) - (+ half-string (* size string-coordinate))))) + (stencil-coordinates + (+ fret-half-thickness (* size (1+ (fret-count fret-range)))) + (+ half-string (* size string-coordinate))))) (ly:round-filled-box (string-x-extent start-coordinates end-coordinates) (string-y-extent start-coordinates end-coordinates) @@ -401,146 +401,146 @@ Line thickness is given by @var{th}, fret & string spacing by @var{size}. Orientation is given by @var{orientation}." (define (helper x) (if (null? (cdr x)) - (fret-stencil (car x)) - (ly:stencil-add (fret-stencil (car x)) - (helper (cdr x))))) + (ly:stencil-add + (fret-stencil (car x)) + (helper (cdr x))))) (let ((fret-list (iota (1+ my-fret-count)))) (helper fret-list))) - (define (fret-stencil fret) - "Make a stencil for @code{fret}, given the + (define (fret-stencil fret) + "Make a stencil for @code{fret}, given the fret-diagram overall parameters." - (let* ((low-string-half-thickness - (* 0.5 - size - th - (string-thickness string-count thickness-factor))) - (fret-half-thickness (* 0.5 size th)) - (start-coordinates - (stencil-coordinates - (* size fret) - (- fret-half-thickness low-string-half-thickness))) - (end-coordinates - (stencil-coordinates - (* size fret) - (* size (1- string-count))))) - (make-line-stencil - (* size th) - (car start-coordinates) (cdr start-coordinates) - (car end-coordinates) (cdr end-coordinates)))) - - (define (draw-barre barre-list) - "Create barre indications for a fret diagram" - (if (not (null? barre-list)) - (let* ((string1 (caar barre-list)) - (string2 (cadar barre-list)) - (barre-fret (caddar barre-list)) - (top-fret (cdr fret-range)) - (low-fret (car fret-range)) - (fret (1+ (- barre-fret low-fret))) - (barre-vertical-offset 0.5) - (dot-center-fret-coordinate (+ (1- fret) dot-position)) - (barre-fret-coordinate + (let* ((low-string-half-thickness + (* 0.5 + size + th + (string-thickness string-count thickness-factor))) + (fret-half-thickness (* 0.5 size th)) + (start-coordinates + (stencil-coordinates + (* size fret) + (- fret-half-thickness low-string-half-thickness))) + (end-coordinates + (stencil-coordinates + (* size fret) + (* size (1- string-count))))) + (make-line-stencil + (* size th) + (car start-coordinates) (cdr start-coordinates) + (car end-coordinates) (cdr end-coordinates)))) + + (define (draw-barre barre-list) + "Create barre indications for a fret diagram" + (if (not (null? barre-list)) + (let* ((string1 (caar barre-list)) + (string2 (cadar barre-list)) + (barre-fret (caddar barre-list)) + (top-fret (cdr fret-range)) + (low-fret (car fret-range)) + (fret (1+ (- barre-fret low-fret))) + (barre-vertical-offset 0.5) + (dot-center-fret-coordinate (+ (1- fret) dot-position)) + (barre-fret-coordinate (+ dot-center-fret-coordinate (* (- barre-vertical-offset 0.5) dot-radius))) - (barre-start-string-coordinate (- string-count string1)) - (barre-end-string-coordinate (- string-count string2)) - (scale-dot-radius (* size dot-radius)) - (barre-type (assoc-get 'barre-type details 'curved)) - (barre-stencil + (barre-start-string-coordinate (- string-count string1)) + (barre-end-string-coordinate (- string-count string2)) + (scale-dot-radius (* size dot-radius)) + (barre-type (assoc-get 'barre-type details 'curved)) + (barre-stencil (cond - ((eq? barre-type 'straight) - (make-straight-barre-stencil - barre-fret-coordinate - barre-start-string-coordinate - barre-end-string-coordinate - scale-dot-radius)) - ((eq? barre-type 'curved) - (make-curved-barre-stencil - barre-fret-coordinate - barre-start-string-coordinate - barre-end-string-coordinate - scale-dot-radius))))) - (if (not (null? (cdr barre-list))) - (ly:stencil-add - barre-stencil - (draw-barre (cdr barre-list))) - barre-stencil )))) - - (define (make-straight-barre-stencil - fret-coordinate - start-string-coordinate - end-string-coordinate - half-thickness) - "Create a straight barre stencil." - (let ((start-point - (stencil-coordinates - (* size fret-coordinate) - (* size start-string-coordinate))) - (end-point - (stencil-coordinates - (* size fret-coordinate) - (* size end-string-coordinate)))) - (make-line-stencil - half-thickness - (car start-point) - (cdr start-point) - (car end-point) - (cdr end-point)))) - - (define (make-curved-barre-stencil - fret-coordinate - start-string-coordinate - end-string-coordinate - half-thickness) - "Create a curved barre stencil." - (let* ((bezier-thick 0.1) - (bezier-height 0.5) - (bezier-list - (make-bezier-sandwich-list - (* size start-string-coordinate) - (* size end-string-coordinate) - (* size fret-coordinate) + ((eq? barre-type 'straight) + (make-straight-barre-stencil + barre-fret-coordinate + barre-start-string-coordinate + barre-end-string-coordinate + scale-dot-radius)) + ((eq? barre-type 'curved) + (make-curved-barre-stencil + barre-fret-coordinate + barre-start-string-coordinate + barre-end-string-coordinate + scale-dot-radius))))) + (if (not (null? (cdr barre-list))) + (ly:stencil-add + barre-stencil + (draw-barre (cdr barre-list))) + barre-stencil )))) + + (define (make-straight-barre-stencil + fret-coordinate + start-string-coordinate + end-string-coordinate + half-thickness) + "Create a straight barre stencil." + (let ((start-point + (stencil-coordinates + (* size fret-coordinate) + (* size start-string-coordinate))) + (end-point + (stencil-coordinates + (* size fret-coordinate) + (* size end-string-coordinate)))) + (make-line-stencil + half-thickness + (car start-point) + (cdr start-point) + (car end-point) + (cdr end-point)))) + + (define (make-curved-barre-stencil + fret-coordinate + start-string-coordinate + end-string-coordinate + half-thickness) + "Create a curved barre stencil." + (let* ((bezier-thick 0.1) + (bezier-height 0.5) + (bezier-list + (make-bezier-sandwich-list + (* size start-string-coordinate) + (* size end-string-coordinate) + (* size fret-coordinate) + (* size bezier-height) + (* size bezier-thick))) + (box-lower-left + (stencil-coordinates + (+ (* size fret-coordinate) half-thickness) + (- (* size start-string-coordinate) half-thickness))) + (box-upper-right + (stencil-coordinates + (- (* size fret-coordinate) (* size bezier-height) - (* size bezier-thick))) - (box-lower-left - (stencil-coordinates - (+ (* size fret-coordinate) half-thickness) - (- (* size start-string-coordinate) half-thickness))) - (box-upper-right - (stencil-coordinates - (- (* size fret-coordinate) - (* size bezier-height) - half-thickness) - (+ (* size end-string-coordinate) half-thickness))) - (x-extent (cons (car box-lower-left) (car box-upper-right))) - (y-extent (cons (cdr box-lower-left) (cdr box-upper-right)))) - (make-bezier-sandwich-stencil - bezier-list - (* size bezier-thick) - x-extent - y-extent))) - - (define (draw-dots dot-list) - "Make dots for fret diagram." - - (let* ( (scale-dot-radius (* size dot-radius)) + half-thickness) + (+ (* size end-string-coordinate) half-thickness))) + (x-extent (cons (car box-lower-left) (car box-upper-right))) + (y-extent (cons (cdr box-lower-left) (cdr box-upper-right)))) + (make-bezier-sandwich-stencil + bezier-list + (* size bezier-thick) + x-extent + y-extent))) + + (define (draw-dots dot-list) + "Make dots for fret diagram." + + (let* ( (scale-dot-radius (* size dot-radius)) (scale-dot-thick (* size th)) (default-dot-color (assoc-get 'dot-color details 'black)) (finger-label-padding 0.3) (dot-label-font-mag - (* scale-dot-radius - (assoc-get 'dot-label-font-mag details 1.0))) + (* scale-dot-radius + (assoc-get 'dot-label-font-mag details 1.0))) (string-label-font-mag - (* size - (assoc-get - 'string-label-font-mag details - (cond ((or (eq? orientation 'landscape) - (eq? orientation 'opposing-landscape)) - 0.5) - (else 0.6))))) + (* size + (assoc-get + 'string-label-font-mag details + (cond ((or (eq? orientation 'landscape) + (eq? orientation 'opposing-landscape)) + 0.5) + (else 0.6))))) (mypair (car dot-list)) (restlist (cdr dot-list)) (string (car mypair)) @@ -548,7 +548,7 @@ fret-diagram overall parameters." (fret-coordinate (* size (+ (1- fret) dot-position))) (string-coordinate (* size (- string-count string))) (dot-coordinates - (stencil-coordinates fret-coordinate string-coordinate)) + (stencil-coordinates fret-coordinate string-coordinate)) (extent (cons (- scale-dot-radius) scale-dot-radius)) (finger (caddr mypair)) (finger (if (number? finger) (number->string finger) finger)) @@ -558,306 +558,306 @@ fret-diagram overall parameters." 'white 'black)) (dot-stencil (if (eq? dot-color 'white) - (ly:stencil-add - (make-circle-stencil + (ly:stencil-add + (make-circle-stencil scale-dot-radius scale-dot-thick #t) - (ly:stencil-in-color + (ly:stencil-in-color (make-circle-stencil - (- scale-dot-radius (* 0.5 scale-dot-thick)) - 0 #t) + (- scale-dot-radius (* 0.5 scale-dot-thick)) + 0 #t) 1 1 1)) - (make-circle-stencil - scale-dot-radius scale-dot-thick #t))) + (make-circle-stencil + scale-dot-radius scale-dot-thick #t))) (positioned-dot - (ly:stencil-translate dot-stencil dot-coordinates)) + (ly:stencil-translate dot-stencil dot-coordinates)) (labeled-dot-stencil - (cond - ((or (eq? finger '())(eq? finger-code 'none)) - positioned-dot) - ((eq? finger-code 'in-dot) - (let ((finger-label - (centered-stencil - (sans-serif-stencil - layout props dot-label-font-mag finger)))) - (ly:stencil-translate - (ly:stencil-add - dot-stencil - (if (eq? dot-color 'white) - finger-label - (ly:stencil-in-color finger-label 1 1 1))) - dot-coordinates))) - ((eq? finger-code 'below-string) - (let* ((label-stencil - (centered-stencil - (sans-serif-stencil - layout props string-label-font-mag - finger))) - (label-fret-offset - (stencil-fretboard-offset - label-stencil 'fret orientation)) - (label-fret-coordinate - (+ (* size - (+ 1 my-fret-count finger-label-padding)) - label-fret-offset)) - (label-string-coordinate string-coordinate) - (label-translation - (stencil-coordinates - label-fret-coordinate - label-string-coordinate))) - (ly:stencil-add - positioned-dot - (ly:stencil-translate - label-stencil - label-translation)))) - (else ;unknown finger-code - positioned-dot)))) - (if (null? restlist) - labeled-dot-stencil - (ly:stencil-add + (cond + ((or (eq? finger '())(eq? finger-code 'none)) + positioned-dot) + ((eq? finger-code 'in-dot) + (let ((finger-label + (centered-stencil + (sans-serif-stencil + layout props dot-label-font-mag finger)))) + (ly:stencil-translate + (ly:stencil-add + dot-stencil + (if (eq? dot-color 'white) + finger-label + (ly:stencil-in-color finger-label 1 1 1))) + dot-coordinates))) + ((eq? finger-code 'below-string) + (let* ((label-stencil + (centered-stencil + (sans-serif-stencil + layout props string-label-font-mag + finger))) + (label-fret-offset + (stencil-fretboard-offset + label-stencil 'fret orientation)) + (label-fret-coordinate + (+ (* size + (+ 1 my-fret-count finger-label-padding)) + label-fret-offset)) + (label-string-coordinate string-coordinate) + (label-translation + (stencil-coordinates + label-fret-coordinate + label-string-coordinate))) + (ly:stencil-add + positioned-dot + (ly:stencil-translate + label-stencil + label-translation)))) + (else ;unknown finger-code + positioned-dot)))) + (if (null? restlist) + labeled-dot-stencil + (ly:stencil-add (draw-dots restlist) labeled-dot-stencil)))) - (define (draw-thick-zero-fret) - "Draw a thick zeroth fret for a fret diagram whose base fret is 1." - (let* ((half-lowest-string-thickness - (* 0.5 th (string-thickness string-count thickness-factor))) - (half-thick (* 0.5 sth)) - (top-fret-thick - (* sth (assoc-get 'top-fret-thickness details 3.0))) - (start-string-coordinate (- half-lowest-string-thickness)) - (end-string-coordinate (+ (* size (1- string-count)) half-thick)) - (start-fret-coordinate half-thick) - (end-fret-coordinate (- half-thick top-fret-thick)) - (lower-left - (stencil-coordinates - start-fret-coordinate start-string-coordinate)) - (upper-right - (stencil-coordinates - end-fret-coordinate end-string-coordinate))) - (ly:round-filled-box - ;; Put limits in order, or else the intervals are considered empty - (ordered-cons (car lower-left) (car upper-right)) - (ordered-cons (cdr lower-left) (cdr upper-right)) - sth))) - - (define (draw-xo xo-list) - "Put open and mute string indications on diagram, as contained in + (define (draw-thick-zero-fret) + "Draw a thick zeroth fret for a fret diagram whose base fret is 1." + (let* ((half-lowest-string-thickness + (* 0.5 th (string-thickness string-count thickness-factor))) + (half-thick (* 0.5 sth)) + (top-fret-thick + (* sth (assoc-get 'top-fret-thickness details 3.0))) + (start-string-coordinate (- half-lowest-string-thickness)) + (end-string-coordinate (+ (* size (1- string-count)) half-thick)) + (start-fret-coordinate half-thick) + (end-fret-coordinate (- half-thick top-fret-thick)) + (lower-left + (stencil-coordinates + start-fret-coordinate start-string-coordinate)) + (upper-right + (stencil-coordinates + end-fret-coordinate end-string-coordinate))) + (ly:round-filled-box + ;; Put limits in order, or else the intervals are considered empty + (ordered-cons (car lower-left) (car upper-right)) + (ordered-cons (cdr lower-left) (cdr upper-right)) + sth))) + + (define (draw-xo xo-list) + "Put open and mute string indications on diagram, as contained in @var{xo-list}." - (let* ((xo-font-mag - (assoc-get 'xo-font-magnification details - (cond ((or (eq? orientation 'landscape) - (eq? orientation 'opposing-landscape)) - 0.4) - (else 0.4)))) - (mypair (car xo-list)) - (restlist (cdr xo-list)) - (glyph-string (if (eq? (car mypair) 'mute) - (assoc-get 'mute-string details "X") - (assoc-get 'open-string details "O"))) - (glyph-string-coordinate (* (- string-count (cadr mypair)) size)) - (glyph-stencil - (centered-stencil - (sans-serif-stencil - layout props (* size xo-font-mag) glyph-string))) - (glyph-stencil-coordinates - (stencil-coordinates 0 glyph-string-coordinate)) - (positioned-glyph - (ly:stencil-translate - glyph-stencil - glyph-stencil-coordinates))) - (if (null? restlist) - positioned-glyph - (ly:stencil-add + (let* ((xo-font-mag + (assoc-get 'xo-font-magnification details + (cond ((or (eq? orientation 'landscape) + (eq? orientation 'opposing-landscape)) + 0.4) + (else 0.4)))) + (mypair (car xo-list)) + (restlist (cdr xo-list)) + (glyph-string (if (eq? (car mypair) 'mute) + (assoc-get 'mute-string details "X") + (assoc-get 'open-string details "O"))) + (glyph-string-coordinate (* (- string-count (cadr mypair)) size)) + (glyph-stencil + (centered-stencil + (sans-serif-stencil + layout props (* size xo-font-mag) glyph-string))) + (glyph-stencil-coordinates + (stencil-coordinates 0 glyph-string-coordinate)) + (positioned-glyph + (ly:stencil-translate + glyph-stencil + glyph-stencil-coordinates))) + (if (null? restlist) + positioned-glyph + (ly:stencil-add positioned-glyph (draw-xo restlist))))) - (define (draw-capo fret) - "Draw a capo indicator across the full width of the fret-board + (define (draw-capo fret) + "Draw a capo indicator across the full width of the fret-board at @var{fret}." - (let* ((capo-thick - (* size (assoc-get 'capo-thickness details 0.5))) - (half-thick (* capo-thick 0.5)) - (last-string-position 0) - (first-string-position (* size (- string-count 1))) - (fret-position ( * size (1- (+ dot-position fret)))) - (start-point - (stencil-coordinates - fret-position - first-string-position)) - (end-point - (stencil-coordinates - fret-position - last-string-position))) - (make-line-stencil - capo-thick - (car start-point) (cdr start-point) - (car end-point) (cdr end-point)))) - - (define (label-fret fret-range) - "Label the base fret on a fret diagram" - (let* ((base-fret (car fret-range)) - (label-font-mag (assoc-get 'fret-label-font-mag details 0.5)) - (label-space (* 0.5 size)) - (label-dir (assoc-get 'label-dir details RIGHT)) - (label-vertical-offset - (assoc-get 'fret-label-vertical-offset details 0)) - (number-type - (assoc-get 'number-type details 'roman-lower)) - (label-text - (cond - ((equal? number-type 'roman-lower) - (fancy-format #f "~(~@r~)" base-fret)) - ((equal? number-type 'roman-upper) - (fancy-format #f "~@r" base-fret)) - ((equal? 'arabic number-type) - (fancy-format #f "~d" base-fret)) - ((equal? 'custom number-type) - (fancy-format #f - (assoc-get 'fret-label-custom-format - details "~a") - base-fret)) - (else (fancy-format #f "~(~@r~)" base-fret)))) - (label-stencil - (centered-stencil - (sans-serif-stencil - layout props (* size label-font-mag) label-text))) - (label-half-width - (stencil-fretboard-offset - label-stencil - 'string - orientation)) - (label-outside-diagram (+ label-space label-half-width))) - (ly:stencil-translate - label-stencil + (let* ((capo-thick + (* size (assoc-get 'capo-thickness details 0.5))) + (half-thick (* capo-thick 0.5)) + (last-string-position 0) + (first-string-position (* size (- string-count 1))) + (fret-position ( * size (1- (+ dot-position fret)))) + (start-point (stencil-coordinates - (* size (+ 1.0 label-vertical-offset)) - (if (eq? label-dir LEFT) - (- label-outside-diagram) - (+ (* size (1- string-count)) label-outside-diagram)))))) - - ;; Here is the body of make-fret-diagram + fret-position + first-string-position)) + (end-point + (stencil-coordinates + fret-position + last-string-position))) + (make-line-stencil + capo-thick + (car start-point) (cdr start-point) + (car end-point) (cdr end-point)))) + + (define (label-fret fret-range) + "Label the base fret on a fret diagram" + (let* ((base-fret (car fret-range)) + (label-font-mag (assoc-get 'fret-label-font-mag details 0.5)) + (label-space (* 0.5 size)) + (label-dir (assoc-get 'label-dir details RIGHT)) + (label-vertical-offset + (assoc-get 'fret-label-vertical-offset details 0)) + (number-type + (assoc-get 'number-type details 'roman-lower)) + (label-text + (cond + ((equal? number-type 'roman-lower) + (fancy-format #f "~(~@r~)" base-fret)) + ((equal? number-type 'roman-upper) + (fancy-format #f "~@r" base-fret)) + ((equal? 'arabic number-type) + (fancy-format #f "~d" base-fret)) + ((equal? 'custom number-type) + (fancy-format #f + (assoc-get 'fret-label-custom-format + details "~a") + base-fret)) + (else (fancy-format #f "~(~@r~)" base-fret)))) + (label-stencil + (centered-stencil + (sans-serif-stencil + layout props (* size label-font-mag) label-text))) + (label-half-width + (stencil-fretboard-offset + label-stencil + 'string + orientation)) + (label-outside-diagram (+ label-space label-half-width))) + (ly:stencil-translate + label-stencil + (stencil-coordinates + (* size (+ 1.0 label-vertical-offset)) + (if (eq? label-dir LEFT) + (- label-outside-diagram) + (+ (* size (1- string-count)) label-outside-diagram)))))) + + ;; Here is the body of make-fret-diagram (set! fret-diagram-stencil - (ly:stencil-add (draw-strings) (draw-frets))) + (ly:stencil-add (draw-strings) (draw-frets))) (if (and (not (null? barre-list)) (not (eq? 'none barre-type))) - (set! fret-diagram-stencil - (ly:stencil-add - (draw-barre barre-list) - fret-diagram-stencil))) + (set! fret-diagram-stencil + (ly:stencil-add + (draw-barre barre-list) + fret-diagram-stencil))) (if (not (null? dot-list)) - (set! fret-diagram-stencil - (ly:stencil-add - fret-diagram-stencil - (draw-dots dot-list)))) + (set! fret-diagram-stencil + (ly:stencil-add + fret-diagram-stencil + (draw-dots dot-list)))) (if (= (car fret-range) 1) - (set! fret-diagram-stencil - (ly:stencil-add - fret-diagram-stencil - (draw-thick-zero-fret)))) + (set! fret-diagram-stencil + (ly:stencil-add + fret-diagram-stencil + (draw-thick-zero-fret)))) (if (not (null? xo-list)) - (let* ((diagram-fret-top - (car (stencil-fretboard-extent + (let* ((diagram-fret-top + (car (stencil-fretboard-extent fret-diagram-stencil 'fret orientation))) - (xo-stencil (draw-xo xo-list)) - (xo-fret-offset - (stencil-fretboard-offset + (xo-stencil (draw-xo xo-list)) + (xo-fret-offset + (stencil-fretboard-offset xo-stencil 'fret orientation)) - (xo-stencil-offset - (stencil-coordinate-offset - (- diagram-fret-top - xo-fret-offset - (* size xo-padding)) - 0))) - (set! fret-diagram-stencil - (ly:stencil-add - fret-diagram-stencil - (ly:stencil-translate - xo-stencil - xo-stencil-offset))))) + (xo-stencil-offset + (stencil-coordinate-offset + (- diagram-fret-top + xo-fret-offset + (* size xo-padding)) + 0))) + (set! fret-diagram-stencil + (ly:stencil-add + fret-diagram-stencil + (ly:stencil-translate + xo-stencil + xo-stencil-offset))))) (if (> capo-fret 0) - (set! fret-diagram-stencil - (ly:stencil-add - fret-diagram-stencil - (draw-capo capo-fret)))) + (set! fret-diagram-stencil + (ly:stencil-add + fret-diagram-stencil + (draw-capo capo-fret)))) (if (> (car fret-range) 1) - (set! fret-diagram-stencil - (ly:stencil-add - fret-diagram-stencil - (label-fret fret-range)))) + (set! fret-diagram-stencil + (ly:stencil-add + fret-diagram-stencil + (label-fret fret-range)))) (ly:stencil-aligned-to fret-diagram-stencil X alignment))) (define (fret-parse-definition-string props definition-string) - "Parse a fret diagram string and return a pair containing: + "Parse a fret diagram string and return a pair containing: @var{props}, modified as necessary by the definition-string a fret-indication list with the appropriate values" - (let* ((fret-count 4) - (string-count 6) - (fret-range (cons 1 fret-count)) - (barre-list '()) - (dot-list '()) - (xo-list '()) - (output-list '()) - (new-props '()) - (details (merge-details 'fret-diagram-details props '())) - (items (string-split definition-string #\;))) - (let parse-item ((myitems items)) - (if (not (null? (cdr myitems))) - (let ((test-string (car myitems))) - (case (car (string->list (substring test-string 0 1))) - ((#\s) (let ((size (get-numeric-from-key test-string))) - (set! props (prepend-alist-chain 'size size props)))) - ((#\t) (let ((th (get-numeric-from-key test-string))) - (set! props (prepend-alist-chain 'thickness th props)))) - ((#\f) (let* ((finger-code (get-numeric-from-key test-string)) - (finger-id (case finger-code - ((0) 'none) - ((1) 'in-dot) - ((2) 'below-string)))) - (set! details - (acons 'finger-code finger-id details)))) - ((#\c) (set! output-list - (cons-fret - (cons - 'barre - (numerify - (string-split (substring test-string 2) #\-))) - output-list))) - ((#\h) (let ((fret-count (get-numeric-from-key test-string))) - (set! details - (acons 'fret-count fret-count details)))) - ((#\w) (let ((string-count (get-numeric-from-key test-string))) - (set! details - (acons 'string-count string-count details)))) - ((#\d) (let ((dot-size (get-numeric-from-key test-string))) - (set! details - (acons 'dot-radius dot-size details)))) - ((#\p) (let ((dot-position (get-numeric-from-key test-string))) - (set! details - (acons 'dot-position dot-position details)))) - (else - (let ((this-list (string-split test-string #\-))) - (if (string->number (cadr this-list)) - (set! output-list - (cons-fret - (cons 'place-fret (numerify this-list)) - output-list)) - (if (equal? (cadr this-list) "x" ) - (set! output-list - (cons-fret - (list 'mute (string->number (car this-list))) - output-list)) - (set! output-list - (cons-fret - (list 'open (string->number (car this-list))) - output-list))))))) - (parse-item (cdr myitems))))) - ;; add the modified details - (set! props - (prepend-alist-chain 'fret-diagram-details details props)) - `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better + (let* ((fret-count 4) + (string-count 6) + (fret-range (cons 1 fret-count)) + (barre-list '()) + (dot-list '()) + (xo-list '()) + (output-list '()) + (new-props '()) + (details (merge-details 'fret-diagram-details props '())) + (items (string-split definition-string #\;))) + (let parse-item ((myitems items)) + (if (not (null? (cdr myitems))) + (let ((test-string (car myitems))) + (case (car (string->list (substring test-string 0 1))) + ((#\s) (let ((size (get-numeric-from-key test-string))) + (set! props (prepend-alist-chain 'size size props)))) + ((#\t) (let ((th (get-numeric-from-key test-string))) + (set! props (prepend-alist-chain 'thickness th props)))) + ((#\f) (let* ((finger-code (get-numeric-from-key test-string)) + (finger-id (case finger-code + ((0) 'none) + ((1) 'in-dot) + ((2) 'below-string)))) + (set! details + (acons 'finger-code finger-id details)))) + ((#\c) (set! output-list + (cons-fret + (cons + 'barre + (numerify + (string-split (substring test-string 2) #\-))) + output-list))) + ((#\h) (let ((fret-count (get-numeric-from-key test-string))) + (set! details + (acons 'fret-count fret-count details)))) + ((#\w) (let ((string-count (get-numeric-from-key test-string))) + (set! details + (acons 'string-count string-count details)))) + ((#\d) (let ((dot-size (get-numeric-from-key test-string))) + (set! details + (acons 'dot-radius dot-size details)))) + ((#\p) (let ((dot-position (get-numeric-from-key test-string))) + (set! details + (acons 'dot-position dot-position details)))) + (else + (let ((this-list (string-split test-string #\-))) + (if (string->number (cadr this-list)) + (set! output-list + (cons-fret + (cons 'place-fret (numerify this-list)) + output-list)) + (if (equal? (cadr this-list) "x" ) + (set! output-list + (cons-fret + (list 'mute (string->number (car this-list))) + output-list)) + (set! output-list + (cons-fret + (list 'open (string->number (car this-list))) + output-list))))))) + (parse-item (cdr myitems))))) + ;; add the modified details + (set! props + (prepend-alist-chain 'fret-diagram-details details props)) + `(,props . ,output-list))) ;ugh -- hard-coded spell -- procedure better (define-public (fret-parse-terse-definition-string props definition-string) @@ -866,7 +866,7 @@ return a pair containing: @var{props}, modified to include the string-count determined by the definition-string, and a fret-indication list with the appropriate values" -;; TODO -- change syntax to fret\string-finger + ;; TODO -- change syntax to fret\string-finger (let* ((details (merge-details 'fret-diagram-details props '())) (barre-start-list '()) @@ -939,9 +939,9 @@ a fret-indication list with the appropriate values" (pair?) ; argument type (list, but use pair? for speed) #:category instrument-specific-markup ; markup type #:properties ((align-dir -0.4) ; properties and defaults - (size 1.0) - (fret-diagram-details) - (thickness 0.5)) + (size 1.0) + (fret-diagram-details) + (thickness 0.5)) "Make a fret diagram containing the symbols indicated in @var{marking-list}. For example, diff --git a/scm/graphviz.scm b/scm/graphviz.scm index 247d30c4a7..fc2076be24 100644 --- a/scm/graphviz.scm +++ b/scm/graphviz.scm @@ -20,8 +20,8 @@ #:use-module (lily) #:export (make-empty-graph add-node add-edge add-cluster - graph-write - )) + graph-write + )) (define graph-type (make-record-type "graph" '(nodes edges clusters name))) @@ -37,21 +37,21 @@ (define (add-cluster graph node-id cluster-name) (let* ((cs (clusters graph)) - (cluster (assoc cluster-name cs)) - (already-in-cluster (if cluster - (cdr cluster) - '()))) + (cluster (assoc cluster-name cs)) + (already-in-cluster (if cluster + (cdr cluster) + '()))) (set-clusters! graph (assoc-set! cs - cluster-name - (cons node-id already-in-cluster))))) + cluster-name + (cons node-id already-in-cluster))))) (define (add-node graph label . cluster-name) (let* ((ns (nodes graph)) (id (length ns))) (set-nodes! graph (assv-set! ns id label)) (if (and (not (null? cluster-name)) - (string? (car cluster-name))) - (add-cluster graph id (car cluster-name))) + (string? (car cluster-name))) + (add-cluster graph id (car cluster-name))) id)) (define (add-edge graph node1 node2) @@ -59,19 +59,19 @@ (define (graph-write graph out) (let ((ns (nodes graph)) - (es (edges graph)) - (cs (clusters graph))) + (es (edges graph)) + (cs (clusters graph))) (ly:message (format #f (_ "Writing graph `~a'...") (port-filename out))) (display "digraph G {\nrankdir=\"LR\"\nnode [shape=rectangle]\n" out) (for-each (lambda (n) (format out "~a [label=\"~a\"]\n" (car n) (cdr n))) - ns) + ns) (for-each (lambda (e) (format out "~a -> ~a\n" (car e) (cdr e))) - es) + es) (for-each (lambda (c) - (format out "subgraph cluster_~a {\nlabel= \"~a\"\ncolor=blue\n" - (string-filter (car c) char-alphabetic?) - (car c)) - (for-each (lambda (n) (format out "~a\n" n)) (cdr c)) - (display "}\n" out)) - cs) + (format out "subgraph cluster_~a {\nlabel= \"~a\"\ncolor=blue\n" + (string-filter (car c) char-alphabetic?) + (car c)) + (for-each (lambda (n) (format out "~a\n" n)) (cdr c)) + (display "}\n" out)) + cs) (display "}" out))) diff --git a/scm/guile-debugger.scm b/scm/guile-debugger.scm index 8027b4f955..be77f2a48f 100644 --- a/scm/guile-debugger.scm +++ b/scm/guile-debugger.scm @@ -31,45 +31,45 @@ #:use-module (ice-9 debugging ice-9-debugger-extensions) #:use-module (ice-9 readline) #:export (set-break! - clear-break! - set-trace-call! - clear-trace-call! - set-trace-subtree! - clear-trace-subtree! - debug-help)) + clear-break! + set-trace-call! + clear-trace-call! + set-trace-subtree! + clear-trace-subtree! + debug-help)) (define (set-break! proc) (install-trap (make <procedure-trap> - #:procedure proc - #:behaviour debug-trap))) + #:procedure proc + #:behaviour debug-trap))) (define (clear-break! proc) (uninstall-trap (make <procedure-trap> - #:procedure proc - #:behaviour debug-trap))) + #:procedure proc + #:behaviour debug-trap))) (define (set-trace-call! proc) (install-trap (make <procedure-trap> - #:procedure proc - #:behaviour (list trace-trap - trace-at-exit)))) + #:procedure proc + #:behaviour (list trace-trap + trace-at-exit)))) (define (clear-trace-call! proc) (uninstall-trap (make <procedure-trap> - #:procedure proc - #:behaviour (list trace-trap - trace-at-exit)))) + #:procedure proc + #:behaviour (list trace-trap + trace-at-exit)))) (define (set-trace-subtree! proc) (install-trap (make <procedure-trap> - #:procedure proc - #:behaviour (list trace-trap - trace-until-exit)))) + #:procedure proc + #:behaviour (list trace-trap + trace-until-exit)))) (define (clear-trace-subtree! proc) (uninstall-trap (make <procedure-trap> - #:procedure proc - #:behaviour (list trace-trap - trace-until-exit)))) + #:procedure proc + #:behaviour (list trace-trap + trace-until-exit)))) (define (debug-help ) (display "\nYou may add the following commands as debugging statements in your source file\n") diff --git a/scm/harp-pedals.scm b/scm/harp-pedals.scm index 66f342c0cd..ee0ea419a4 100644 --- a/scm/harp-pedals.scm +++ b/scm/harp-pedals.scm @@ -20,8 +20,8 @@ (define-markup-command (harp-pedal layout props definition-string) (string?) #:category instrument-specific-markup ; markup type for the documentation! #:properties ((size 1.2) - (harp-pedal-details '()) - (thickness 0.5)) + (harp-pedal-details '()) + (thickness 0.5)) "Make a harp pedal diagram. Possible elements in @var{definition-string}: @@ -132,15 +132,15 @@ It contains the following settings: @code{box-offset} ;; Parse the harp pedal definition string into list of directions (-1/0/1), #\o and #\| (define (harp-pedals-parse-string definition-string) - "Parse a harp pedals diagram string and return a list containing 1, 0, -1, #\\o or #\\|" + "Parse a harp pedals diagram string and return a list containing 1, 0, -1, #\\o or #\\|" (map (lambda (c) - (case c - ((#\^) 1) - ((#\v) -1) - ((#\-) 0) - ((#\| #\o) c) - (else c))) - (string->list definition-string))) + (case c + ((#\^) 1) + ((#\v) -1) + ((#\-) 0) + ((#\| #\o) c) + (else c))) + (string->list definition-string))) ;; Analyze the pedal-list: Return (pedalcount . (divider positions)) @@ -149,23 +149,23 @@ It contains the following settings: @code{box-offset} (pedalcount 0) (dividerpositions '())) (if (null? pedals) - (cons pedalcount (reverse dividerpositions)) + (cons pedalcount (reverse dividerpositions)) - (case (car pedals) - ((-1 0 1) (check (cdr pedals) (+ pedalcount 1) dividerpositions)) - ((#\|) (check (cdr pedals) pedalcount (cons pedalcount dividerpositions))) - (else (check (cdr pedals) pedalcount dividerpositions)))))) + (case (car pedals) + ((-1 0 1) (check (cdr pedals) (+ pedalcount 1) dividerpositions)) + ((#\|) (check (cdr pedals) pedalcount (cons pedalcount dividerpositions))) + (else (check (cdr pedals) pedalcount dividerpositions)))))) ;; Sanity checks, spit out warning if pedal-list violates the conventions (define (harp-pedal-check pedal-list) "Perform some sanity checks for harp pedals (7 pedals, divider after third)" (let ((info (harp-pedal-info pedal-list))) - ; 7 pedals: + ; 7 pedals: (if (not (equal? (car info) 7)) - (ly:warning "Harp pedal diagram contains ~a pedals rather than the usual 7." (car info))) - ; One divider after third pedal: + (ly:warning "Harp pedal diagram contains ~a pedals rather than the usual 7." (car info))) + ; One divider after third pedal: (if (null? (cdr info)) - (ly:warning "Harp pedal diagram does not contain a divider (usually after third pedal).") - (if (not (equal? (cdr info) '(3))) - (ly:warning "Harp pedal diagram contains dividers at positions ~a. Normally, there is only one divider after the third pedal." (cdr info)))))) + (ly:warning "Harp pedal diagram does not contain a divider (usually after third pedal).") + (if (not (equal? (cdr info) '(3))) + (ly:warning "Harp pedal diagram contains dividers at positions ~a. Normally, there is only one divider after the third pedal." (cdr info)))))) diff --git a/scm/layout-beam.scm b/scm/layout-beam.scm index f72afacf0d..fe4fa4df43 100644 --- a/scm/layout-beam.scm +++ b/scm/layout-beam.scm @@ -18,57 +18,57 @@ (define check-beam-quant (lambda (posl posr) (lambda (beam posns) - "Check whether BEAM has POSL and POSR quants. POSL are (POSITION -. QUANT) pairs, where QUANT is -1 (hang), 0 (center), 1 (sit) or -2/ 2 (inter) + "Check whether BEAM has POSL and POSR quants. POSL are (POSITION +. QUANT) pairs, where QUANT is -1 (hang), 0 (center), 1 (sit) or -2/ 2 (inter) " - (let* ((thick (ly:grob-property beam 'beam-thickness)) - (layout (ly:grob-layout beam)) - (lthick (ly:output-def-lookup layout 'line-thickness)) - (staff-thick lthick) ; fixme. - (quant->coord (lambda (p q) - (if (= 2 (abs q)) - (+ p (/ q 4.0)) - (+ p (- (* 0.5 q thick) (* 0.5 q lthick)))))) - (want-l (quant->coord (car posl) (cdr posl))) - (want-r (quant->coord (car posr) (cdr posr))) - (almost-equal (lambda (x y) (< (abs (- x y)) 1e-3)))) - - (if (or (not (almost-equal want-l (car posns))) - (not (almost-equal want-r (cdr posns)))) - (begin - (ly:warning (_ "Error in beam quanting. Expected (~S,~S) found ~S.") - want-l want-r posns) - (set! (ly:grob-property beam 'annotation) - (format #f "(~S,~S)" want-l want-r)))) - posns)))) + (let* ((thick (ly:grob-property beam 'beam-thickness)) + (layout (ly:grob-layout beam)) + (lthick (ly:output-def-lookup layout 'line-thickness)) + (staff-thick lthick) ; fixme. + (quant->coord (lambda (p q) + (if (= 2 (abs q)) + (+ p (/ q 4.0)) + (+ p (- (* 0.5 q thick) (* 0.5 q lthick)))))) + (want-l (quant->coord (car posl) (cdr posl))) + (want-r (quant->coord (car posr) (cdr posr))) + (almost-equal (lambda (x y) (< (abs (- x y)) 1e-3)))) + + (if (or (not (almost-equal want-l (car posns))) + (not (almost-equal want-r (cdr posns)))) + (begin + (ly:warning (_ "Error in beam quanting. Expected (~S,~S) found ~S.") + want-l want-r posns) + (set! (ly:grob-property beam 'annotation) + (format #f "(~S,~S)" want-l want-r)))) + posns)))) (define check-beam-slope-sign (lambda (comparison) (lambda (beam posns) - "Check whether the slope of BEAM is correct wrt. COMPARISON." - (let* ((slope-sign (- (cdr posns) (car posns))) - (correct (comparison slope-sign 0))) - (if (not correct) - (begin - (ly:warning (_ "Error in beam quanting. Expected ~S 0, found ~S.") - (procedure-name comparison) slope-sign) - (set! (ly:grob-property beam 'annotation) - (format #f "~S 0" (procedure-name comparison)))) - (set! (ly:grob-property beam 'annotation) "")) - posns)))) + "Check whether the slope of BEAM is correct wrt. COMPARISON." + (let* ((slope-sign (- (cdr posns) (car posns))) + (correct (comparison slope-sign 0))) + (if (not correct) + (begin + (ly:warning (_ "Error in beam quanting. Expected ~S 0, found ~S.") + (procedure-name comparison) slope-sign) + (set! (ly:grob-property beam 'annotation) + (format #f "~S 0" (procedure-name comparison)))) + (set! (ly:grob-property beam 'annotation) "")) + posns)))) (define-public (check-quant-callbacks l r) (lambda (grob) ((check-beam-quant l r) - grob - (beam::place-broken-parts-individually grob)))) + grob + (beam::place-broken-parts-individually grob)))) (define-public (check-slope-callbacks comparison) (lambda (grob) ((check-beam-slope-sign comparison) - grob - (beam::place-broken-parts-individually grob)))) + grob + (beam::place-broken-parts-individually grob)))) diff --git a/scm/lily-library.scm b/scm/lily-library.scm index 48ee33cf50..b334517de1 100644 --- a/scm/lily-library.scm +++ b/scm/lily-library.scm @@ -84,35 +84,35 @@ ;; durations (define-public (duration-log-factor lognum) -"Given a logarithmic duration number, return the length of the duration, + "Given a logarithmic duration number, return the length of the duration, as a number of whole notes." (or (and (exact? lognum) (integer? lognum)) - (scm-error 'wrong-type-arg "duration-log-factor" "Not an integer: ~S" (list lognum) #f)) + (scm-error 'wrong-type-arg "duration-log-factor" "Not an integer: ~S" (list lognum) #f)) (if (<= lognum 0) - (ash 1 (- lognum)) - (/ (ash 1 lognum)))) + (ash 1 (- lognum)) + (/ (ash 1 lognum)))) (define-public (duration-dot-factor dotcount) -"Given a count of the dots used to extend a musical duration, return + "Given a count of the dots used to extend a musical duration, return the numeric factor by which they increase the duration." (or (and (exact? dotcount) (integer? dotcount) (>= dotcount 0)) - (scm-error 'wrong-type-arg "duration-dot-factor" "Not a count: ~S" (list dotcount) #f)) + (scm-error 'wrong-type-arg "duration-dot-factor" "Not a count: ~S" (list dotcount) #f)) (- 2 (/ (ash 1 dotcount)))) (define-public (duration-length dur) -"Return the overall length of a duration, as a number of whole notes. + "Return the overall length of a duration, as a number of whole notes. (Not to be confused with ly:duration-length, which returns a less-useful -moment object.)" + moment object.)" (ly:moment-main (ly:duration-length dur))) (define-public (duration-visual dur) -"Given a duration object, return the visual part of the duration (base + "Given a duration object, return the visual part of the duration (base note length and dot count), in the form of a duration object with non-visual scale factor 1." (ly:make-duration (ly:duration-log dur) (ly:duration-dot-count dur) 1)) (define-public (duration-visual-length dur) -"Given a duration object, return the length of the visual part of the + "Given a duration object, return the length of the visual part of the duration (base note length and dot count), as a number of whole notes." (duration-length (duration-visual dur))) @@ -128,15 +128,15 @@ duration (base note length and dot count), as a number of whole notes." "Toplevel book-part handler." (define (add-bookpart book-part) (ly:parser-define! - parser 'toplevel-bookparts - (cons book-part (ly:parser-lookup parser 'toplevel-bookparts)))) + parser 'toplevel-bookparts + (cons book-part (ly:parser-lookup parser 'toplevel-bookparts)))) ;; If toplevel scores have been found before this \bookpart, ;; add them first to a dedicated bookpart (if (pair? (ly:parser-lookup parser 'toplevel-scores)) (begin - (add-bookpart (ly:make-book-part - (ly:parser-lookup parser 'toplevel-scores))) - (ly:parser-define! parser 'toplevel-scores (list)))) + (add-bookpart (ly:make-book-part + (ly:parser-lookup parser 'toplevel-scores))) + (ly:parser-define! parser 'toplevel-scores (list)))) (add-bookpart book-part)) (define-public (collect-scores-for-book parser score) @@ -148,7 +148,7 @@ duration (base note length and dot count), as a number of whole notes." (define (music-property symbol) (ly:music-property music symbol #f)) (cond ((music-property 'page-marker) - ;; a page marker: set page break/turn permissions or label + ;; a page marker: set page break/turn permissions or label (let ((label (music-property 'page-label))) (if (symbol? label) (score-handler (ly:make-page-label-marker label)))) @@ -163,23 +163,23 @@ duration (base note length and dot count), as a number of whole notes." '(line-break-permission page-break-permission page-turn-permission))) ((not (music-property 'void)) - ;; a regular music expression: make a score with this music - ;; void music is discarded - (score-handler (scorify-music music parser))))) + ;; a regular music expression: make a score with this music + ;; void music is discarded + (score-handler (scorify-music music parser))))) (define-public (collect-music-for-book parser music) "Top-level music handler." (collect-music-aux (lambda (score) - (collect-scores-for-book parser score)) + (collect-scores-for-book parser score)) parser - music)) + music)) (define-public (collect-book-music-for-book parser book music) "Book music handler." (collect-music-aux (lambda (score) - (ly:book-add-score! book score)) + (ly:book-add-score! book score)) parser - music)) + music)) (define-public (scorify-music music parser) "Preprocess @var{music}." @@ -199,8 +199,8 @@ calls to bookOutputName function" bookoutput function" (let ((book-output-suffix (paper-variable parser book 'output-suffix))) (if (not (string? book-output-suffix)) - (ly:parser-lookup parser 'output-suffix) - book-output-suffix))) + (ly:parser-lookup parser 'output-suffix) + book-output-suffix))) (define-public current-outfile-name #f) ; for use by regression tests @@ -210,11 +210,11 @@ bookoutput function" ;; the file-name concatenated with any potential output-suffix value ;; as the key to out internal a-list (let* ((base-name (get-current-filename parser book)) - (output-suffix (get-current-suffix parser book)) - (alist-key (format #f "~a~a" base-name output-suffix)) - (counter-alist (ly:parser-lookup parser 'counter-alist)) - (output-count (assoc-get alist-key counter-alist 0)) - (result base-name)) + (output-suffix (get-current-suffix parser book)) + (alist-key (format #f "~a~a" base-name output-suffix)) + (counter-alist (ly:parser-lookup parser 'counter-alist)) + (output-count (assoc-get alist-key counter-alist 0)) + (result base-name)) ;; Allow all ASCII alphanumerics, including accents (if (string? output-suffix) (set! result @@ -237,8 +237,8 @@ bookoutput function" (define (print-book-with parser book process-procedure) (let* ((paper (ly:parser-lookup parser '$defaultpaper)) - (layout (ly:parser-lookup parser '$defaultlayout)) - (outfile-name (get-outfile-name parser book))) + (layout (ly:parser-lookup parser '$defaultlayout)) + (outfile-name (get-outfile-name parser book))) (process-procedure book paper layout outfile-name))) (define-public (print-book-with-defaults parser book) @@ -249,89 +249,89 @@ bookoutput function" ;; Add a score to the current bookpart, book or toplevel (define-public (add-score parser score) - (cond - ((ly:parser-lookup parser '$current-bookpart) - ((ly:parser-lookup parser 'bookpart-score-handler) - (ly:parser-lookup parser '$current-bookpart) score)) - ((ly:parser-lookup parser '$current-book) - ((ly:parser-lookup parser 'book-score-handler) - (ly:parser-lookup parser '$current-book) score)) - (else - ((ly:parser-lookup parser 'toplevel-score-handler) parser score)))) + (cond + ((ly:parser-lookup parser '$current-bookpart) + ((ly:parser-lookup parser 'bookpart-score-handler) + (ly:parser-lookup parser '$current-bookpart) score)) + ((ly:parser-lookup parser '$current-book) + ((ly:parser-lookup parser 'book-score-handler) + (ly:parser-lookup parser '$current-book) score)) + (else + ((ly:parser-lookup parser 'toplevel-score-handler) parser score)))) (define-public paper-variable (let ((get-papers - (lambda (parser book) - (append (if (and book (ly:output-def? (ly:book-paper book))) - (list (ly:book-paper book)) - '()) - (ly:parser-lookup parser '$papers) - (list (ly:parser-lookup parser '$defaultpaper)))))) + (lambda (parser book) + (append (if (and book (ly:output-def? (ly:book-paper book))) + (list (ly:book-paper book)) + '()) + (ly:parser-lookup parser '$papers) + (list (ly:parser-lookup parser '$defaultpaper)))))) (make-procedure-with-setter (lambda (parser book symbol) (any (lambda (p) (ly:output-def-lookup p symbol #f)) - (get-papers parser book))) + (get-papers parser book))) (lambda (parser book symbol value) (ly:output-def-set-variable! - (car (get-papers parser book)) - symbol value))))) + (car (get-papers parser book)) + symbol value))))) (define-public (add-text parser text) (add-score parser (list text))) (define-public (add-music parser music) (collect-music-aux (lambda (score) - (add-score parser score)) + (add-score parser score)) parser - music)) + music)) (define-public (context-mod-from-music parser music) (let ((warn #t) (mods (ly:make-context-mod))) (let loop ((m music)) (if (music-is-of-type? m 'layout-instruction-event) - (let ((symbol (ly:music-property m 'symbol))) - (ly:add-context-mod - mods - (case (ly:music-property m 'name) - ((PropertySet) - (list 'assign - symbol - (ly:music-property m 'value))) - ((PropertyUnset) - (list 'unset symbol)) - ((OverrideProperty) - (cons* 'push - symbol - (ly:music-property m 'grob-value) + (let ((symbol (ly:music-property m 'symbol))) + (ly:add-context-mod + mods + (case (ly:music-property m 'name) + ((PropertySet) + (list 'assign + symbol + (ly:music-property m 'value))) + ((PropertyUnset) + (list 'unset symbol)) + ((OverrideProperty) + (cons* 'push + symbol + (ly:music-property m 'grob-value) (cond ((ly:music-property m 'grob-property #f) => list) (else (ly:music-property m 'grob-property-path))))) ((RevertProperty) - (cons* 'pop - symbol + (cons* 'pop + symbol (cond ((ly:music-property m 'grob-property #f) => list) (else (ly:music-property m 'grob-property-path)))))))) - (case (ly:music-property m 'name) - ((ApplyContext) - (ly:add-context-mod mods - (list 'apply - (ly:music-property m 'procedure)))) - ((ContextSpeccedMusic) - (loop (ly:music-property m 'element))) - (else - (let ((callback (ly:music-property m 'elements-callback))) - (if (procedure? callback) - (for-each loop (callback m)) - (if (and warn (ly:duration? (ly:music-property m 'duration))) - (begin - (ly:music-warning - music - (_ "Music unsuitable for context-mod")) - (set! warn #f))))))))) + (case (ly:music-property m 'name) + ((ApplyContext) + (ly:add-context-mod mods + (list 'apply + (ly:music-property m 'procedure)))) + ((ContextSpeccedMusic) + (loop (ly:music-property m 'element))) + (else + (let ((callback (ly:music-property m 'elements-callback))) + (if (procedure? callback) + (for-each loop (callback m)) + (if (and warn (ly:duration? (ly:music-property m 'duration))) + (begin + (ly:music-warning + music + (_ "Music unsuitable for context-mod")) + (set! warn #f))))))))) mods)) (define-public (context-defs-from-music parser output-def music) @@ -345,64 +345,64 @@ bookoutput function" ;; context modification results in a reasonably recognizable ;; error. (if (music-is-of-type? m 'layout-instruction-event) - (ly:add-context-mod - mods - (case (ly:music-property m 'name) - ((PropertySet) - (list 'assign - (ly:music-property m 'symbol) - (ly:music-property m 'value))) - ((PropertyUnset) - (list 'unset - (ly:music-property m 'symbol))) - ((OverrideProperty) - (cons* 'push - (ly:music-property m 'symbol) - (ly:music-property m 'grob-value) + (ly:add-context-mod + mods + (case (ly:music-property m 'name) + ((PropertySet) + (list 'assign + (ly:music-property m 'symbol) + (ly:music-property m 'value))) + ((PropertyUnset) + (list 'unset + (ly:music-property m 'symbol))) + ((OverrideProperty) + (cons* 'push + (ly:music-property m 'symbol) + (ly:music-property m 'grob-value) (cond ((ly:music-property m 'grob-property #f) => list) (else (ly:music-property m 'grob-property-path))))) - ((RevertProperty) - (cons* 'pop - (ly:music-property m 'symbol) + ((RevertProperty) + (cons* 'pop + (ly:music-property m 'symbol) (cond ((ly:music-property m 'grob-property #f) => list) (else (ly:music-property m 'grob-property-path))))))) - (case (ly:music-property m 'name) - ((ApplyContext) - (ly:add-context-mod mods - (list 'apply - (ly:music-property m 'procedure)))) - ((ContextSpeccedMusic) - ;; Use let* here to let defs catch up with modifications - ;; to the context defs made in the recursion - (let* ((mods (loop (ly:music-property m 'element) - (ly:make-context-mod))) - (defs (ly:output-find-context-def - output-def (ly:music-property m 'context-type)))) - (if (null? defs) - (ly:music-warning - music - (ly:format (_ "Cannot find context-def \\~a") - (ly:music-property m 'context-type))) - (for-each - (lambda (entry) - (ly:output-def-set-variable! - output-def (car entry) - (ly:context-def-modify (cdr entry) mods))) - defs)))) - (else - (let ((callback (ly:music-property m 'elements-callback))) - (if (procedure? callback) - (fold loop mods (callback m)) - (if (and warn (ly:duration? (ly:music-property m 'duration))) - (begin - (ly:music-warning - music - (_ "Music unsuitable for output-def")) - (set! warn #f)))))))) + (case (ly:music-property m 'name) + ((ApplyContext) + (ly:add-context-mod mods + (list 'apply + (ly:music-property m 'procedure)))) + ((ContextSpeccedMusic) + ;; Use let* here to let defs catch up with modifications + ;; to the context defs made in the recursion + (let* ((mods (loop (ly:music-property m 'element) + (ly:make-context-mod))) + (defs (ly:output-find-context-def + output-def (ly:music-property m 'context-type)))) + (if (null? defs) + (ly:music-warning + music + (ly:format (_ "Cannot find context-def \\~a") + (ly:music-property m 'context-type))) + (for-each + (lambda (entry) + (ly:output-def-set-variable! + output-def (car entry) + (ly:context-def-modify (cdr entry) mods))) + defs)))) + (else + (let ((callback (ly:music-property m 'elements-callback))) + (if (procedure? callback) + (fold loop mods (callback m)) + (if (and warn (ly:duration? (ly:music-property m 'duration))) + (begin + (ly:music-warning + music + (_ "Music unsuitable for output-def")) + (set! warn #f)))))))) mods))) @@ -416,26 +416,26 @@ bookoutput function" (define-public (uniqued-alist alist acc) (if (null? alist) acc (if (assoc (caar alist) acc) - (uniqued-alist (cdr alist) acc) - (uniqued-alist (cdr alist) (cons (car alist) acc))))) + (uniqued-alist (cdr alist) acc) + (uniqued-alist (cdr alist) (cons (car alist) acc))))) (define-public (alist<? x y) (string<? (symbol->string (car x)) - (symbol->string (car y)))) + (symbol->string (car y)))) (define (map-alist-vals func list) "map FUNC over the vals of LIST, leaving the keys." (if (null? list) '() (cons (cons (caar list) (func (cdar list))) - (map-alist-vals func (cdr list))))) + (map-alist-vals func (cdr list))))) (define (map-alist-keys func list) "map FUNC over the keys of an alist LIST, leaving the vals." (if (null? list) '() (cons (cons (func (caar list)) (cdar list)) - (map-alist-keys func (cdr list))))) + (map-alist-keys func (cdr list))))) (define-public (first-member members lst) "Return first successful member (of member) from @var{members} in @@ -450,8 +450,8 @@ bookoutput function" (if (null? alist) '() (cons (caar alist) - (cons (cdar alist) - (flatten-alist (cdr alist)))))) + (cons (cdar alist) + (flatten-alist (cdr alist)))))) (define (assoc-remove key alist) "Remove key (and its corresponding value) from an alist. @@ -473,19 +473,19 @@ For example: @code{guile> (map-selected-alist-keys - '(a b) '((a . 1) (b . -2) (c . 3) (d . 4)))} @code{((a . -1) (b . 2) (c . 3) (d . 4)} @end example" - (define (map-selected-alist-keys-helper function key alist) - (map + (define (map-selected-alist-keys-helper function key alist) + (map (lambda (pair) (if (equal? key (car pair)) (cons key (function (cdr pair))) pair)) alist)) - (if (null? keys) - alist - (map-selected-alist-keys - function - (cdr keys) - (map-selected-alist-keys-helper function (car keys) alist)))) + (if (null? keys) + alist + (map-selected-alist-keys + function + (cdr keys) + (map-selected-alist-keys-helper function (car keys) alist)))) ;;;;;;;;;;;;;;;; ;; vector @@ -523,13 +523,13 @@ For example: (define (helper todo acc-vector k) (if (null? todo) - acc-vector - (begin - (if (< k 0) - (set! k (+ n k))) + acc-vector + (begin + (if (< k 0) + (set! k (+ n k))) - (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k))) - (helper (cdr todo) acc-vector (1- k))))) + (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k))) + (helper (cdr todo) acc-vector (1- k))))) (helper lst (make-vector n '()) (1- n))) @@ -546,10 +546,10 @@ For example: (fold-right (lambda (elem prev) - (if (pair? prev) - (cons elem (cons intermediate prev)) - (list elem))) - '() lst)) + (if (pair? prev) + (cons elem (cons intermediate prev)) + (list elem))) + '() lst)) (define-public (filtered-map proc lst) (filter @@ -573,12 +573,12 @@ for comparisons." (reverse! (fold (lambda (x acc) - (if (null? acc) - (list x) - (if (equal? x (car acc)) - acc - (cons x acc)))) - '() lst) '())) + (if (null? acc) + (list x) + (if (equal? x (car acc)) + acc + (cons x acc)))) + '() lst) '())) (define (split-at-predicate pred lst) "Split LST into two lists at the first element that returns #f for @@ -608,20 +608,20 @@ executing @samp{(split-list-by-separator '(a 0 b c 1 d) number?)} returns (define-public (offset-add a b) (cons (+ (car a) (car b)) - (+ (cdr a) (cdr b)))) + (+ (cdr a) (cdr b)))) (define-public (offset-flip-y o) (cons (car o) (- (cdr o)))) (define-public (offset-scale o scale) (cons (* (car o) scale) - (* (cdr o) scale))) + (* (cdr o) scale))) (define-public (ly:list->offsets accum coords) (if (null? coords) accum (cons (cons (car coords) (cadr coords)) - (ly:list->offsets accum (cddr coords))))) + (ly:list->offsets accum (cddr coords))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; intervals @@ -637,7 +637,7 @@ executing @samp{(split-list-by-separator '(a 0 b c 1 d) number?)} returns (define-public (ordered-cons a b) (cons (min a b) - (max a b))) + (max a b))) (define-public (interval-bound interval dir) ((if (= dir RIGHT) cdr car) interval)) @@ -647,7 +647,7 @@ executing @samp{(split-list-by-separator '(a 0 b c 1 d) number?)} returns right (@var{dir}=+1)." (* (+ (interval-start interval) (interval-end interval) - (* dir (- (interval-end interval) (interval-start interval)))) + (* dir (- (interval-end interval) (interval-start interval)))) 0.5)) (define-public (interval-center x) @@ -665,31 +665,31 @@ right (@var{dir}=+1)." (define-public (interval-scale iv factor) (cons (* (car iv) factor) - (* (cdr iv) factor))) + (* (cdr iv) factor))) (define-public (interval-widen iv amount) (cons (- (car iv) amount) - (+ (cdr iv) amount))) + (+ (cdr iv) amount))) (define-public (interval-empty? iv) - (> (car iv) (cdr iv))) + (> (car iv) (cdr iv))) (define-public (interval-union i1 i2) (cons - (min (car i1) (car i2)) - (max (cdr i1) (cdr i2)))) + (min (car i1) (car i2)) + (max (cdr i1) (cdr i2)))) (define-public (interval-intersection i1 i2) - (cons - (max (car i1) (car i2)) - (min (cdr i1) (cdr i2)))) + (cons + (max (car i1) (car i2)) + (min (cdr i1) (cdr i2)))) (define-public (interval-sane? i) (not (or (nan? (car i)) - (inf? (car i)) - (nan? (cdr i)) - (inf? (cdr i)) - (> (car i) (cdr i))))) + (inf? (car i)) + (nan? (cdr i)) + (inf? (cdr i)) + (> (car i) (cdr i))))) (define-public (add-point interval p) (cons (min (interval-start interval) p) @@ -706,19 +706,19 @@ right (@var{dir}=+1)." (define (coord-operation operator operand coordinate) (if (pair? operand) - (cons (operator (coord-x operand) (coord-x coordinate)) - (operator (coord-y operand) (coord-y coordinate))) - (cons (operator operand (coord-x coordinate)) - (operator operand (coord-y coordinate))))) + (cons (operator (coord-x operand) (coord-x coordinate)) + (operator (coord-y operand) (coord-y coordinate))) + (cons (operator operand (coord-x coordinate)) + (operator operand (coord-y coordinate))))) (define (coord-apply function coordinate) (if (pair? function) - (cons - ((coord-x function) (coord-x coordinate)) - ((coord-y function) (coord-y coordinate))) - (cons - (function (coord-x coordinate)) - (function (coord-y coordinate))))) + (cons + ((coord-x function) (coord-x coordinate)) + ((coord-y function) (coord-y coordinate))) + (cons + (function (coord-x coordinate)) + (function (coord-y coordinate))))) (define-public (coord-translate coordinate amount) (coord-operation + amount coordinate)) @@ -728,16 +728,16 @@ right (@var{dir}=+1)." (define-public (coord-rotate coordinate degrees-in-radians) (let* - ((coordinate - (cons - (exact->inexact (coord-x coordinate)) - (exact->inexact (coord-y coordinate)))) - (radius - (sqrt - (+ (* (coord-x coordinate) (coord-x coordinate)) - (* (coord-y coordinate) (coord-y coordinate))))) - (angle (angle-0-2pi (atan (coord-y coordinate) (coord-x coordinate))))) - (cons + ((coordinate + (cons + (exact->inexact (coord-x coordinate)) + (exact->inexact (coord-y coordinate)))) + (radius + (sqrt + (+ (* (coord-x coordinate) (coord-x coordinate)) + (* (coord-y coordinate) (coord-y coordinate))))) + (angle (angle-0-2pi (atan (coord-y coordinate) (coord-x coordinate))))) + (cons (* radius (cos (+ angle degrees-in-radians))) (* radius (sin (+ angle degrees-in-radians)))))) @@ -776,31 +776,31 @@ right (@var{dir}=+1)." (define-public (ellipse-radius x-radius y-radius angle) (/ - (* x-radius y-radius) - (sqrt - (+ (* (expt y-radius 2) - (* (cos angle) (cos angle))) - (* (expt x-radius 2) - (* (sin angle) (sin angle))))))) + (* x-radius y-radius) + (sqrt + (+ (* (expt y-radius 2) + (* (cos angle) (cos angle))) + (* (expt x-radius 2) + (* (sin angle) (sin angle))))))) (define-public (polar->rectangular radius angle-in-degrees) "Return polar coordinates (@var{radius}, @var{angle-in-degrees}) as rectangular coordinates @ode{(x-length . y-length)}." (let ((complex (make-polar - radius - (degrees->radians angle-in-degrees)))) - (cons - (real-part complex) - (imag-part complex)))) + radius + (degrees->radians angle-in-degrees)))) + (cons + (real-part complex) + (imag-part complex)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; string (define-public (string-endswith s suffix) (equal? suffix (substring s - (max 0 (- (string-length s) (string-length suffix))) - (string-length s)))) + (max 0 (- (string-length s) (string-length suffix))) + (string-length s)))) (define-public (string-startswith s prefix) (equal? prefix (substring s 0 (min (string-length s) (string-length prefix))))) @@ -810,8 +810,8 @@ as rectangular coordinates @ode{(x-length . y-length)}." ((= i 0) "o") ((< i 0) (string-append "n" (string-encode-integer (- i)))) (else (string-append - (make-string 1 (integer->char (+ 65 (modulo i 26)))) - (string-encode-integer (quotient i 26)))))) + (make-string 1 (integer->char (+ 65 (modulo i 26)))) + (string-encode-integer (quotient i 26)))))) (define (number->octal-string x) (let* ((n (inexact->exact x)) @@ -828,14 +828,14 @@ as rectangular coordinates @ode{(x-length . y-length)}." (define-public (ly:number-pair->string c) (string-append (ly:number->string (car c)) " " - (ly:number->string (cdr c)))) + (ly:number->string (cdr c)))) (define-public (dir-basename file . rest) "Strip suffixes in @var{rest}, but leave directory component for @var{file}." (define (inverse-basename x y) (basename y x)) (simple-format #f "~a/~a" (dirname file) - (fold inverse-basename file rest))) + (fold inverse-basename file rest))) (define-public (write-me message x) "Return @var{x}. Display @var{message} and write @var{x}. @@ -864,8 +864,8 @@ Handy for debugging, possibly turned off." "Create new list, inserting @var{between} between elements of @var{lst}." (define (conc x y ) (if (eq? y #f) - (list x) - (cons x (cons between y)))) + (list x) + (cons x (cons between y)))) (fold-right conc #f lst)) (define-public (string-regexp-substitute a b str) @@ -877,9 +877,9 @@ Handy for debugging, possibly turned off." (define (notice match) (set! matches (cons (substring (match:string match) - end-of-prev-match - (match:start match)) - matches)) + end-of-prev-match + (match:start match)) + matches)) (set! end-of-prev-match (match:end match))) (regexp-substitute/global #f regex str notice 'post) @@ -889,7 +889,7 @@ Handy for debugging, possibly turned off." matches (cons (substring str end-of-prev-match (string-length str)) matches))) - (reverse matches)) + (reverse matches)) ;;;;;;;;;;;;;;;; ;; other @@ -906,13 +906,13 @@ applied to function @var{getter}.") (if (<= end start) start (let* ((compare (quotient (+ start end) 2)) - (get-val (getter compare))) - (cond - ((< target-val get-val) - (set! end (1- compare))) - ((< get-val target-val) - (set! start (1+ compare)))) - (binary-search start end getter target-val)))) + (get-val (getter compare))) + (cond + ((< target-val get-val) + (set! end (1- compare))) + ((< get-val target-val) + (set! start (1+ compare)))) + (binary-search start end getter target-val)))) (define-public (car< a b) (< (car a) (car b))) @@ -932,7 +932,7 @@ in module @var{module}. In that case evaluate, otherwise print a warning and set an optional @var{default}." (let* ((unavailable? (lambda (sym) (not (module-defined? module sym)))) - (sym-unavailable + (sym-unavailable (filter unavailable? (filter symbol? (flatten-list symbol))))) @@ -940,10 +940,10 @@ print a warning and set an optional @var{default}." (eval symbol module) (let* ((def (and (pair? default) (car default)))) (ly:programming-error - "cannot evaluate ~S in module ~S, setting to ~S" - (object->string symbol) - (object->string module) - (object->string def)) + "cannot evaluate ~S in module ~S, setting to ~S" + (object->string symbol) + (object->string module) + (object->string def)) def)))) ;; @@ -951,18 +951,18 @@ print a warning and set an optional @var{default}." ;; (define-public (scm->string val) (if (and (procedure? val) - (symbol? (procedure-name val))) + (symbol? (procedure-name val))) (symbol->string (procedure-name val)) (string-append (if (self-evaluating? val) - (if (string? val) - "\"" - "") - "'") + (if (string? val) + "\"" + "") + "'") (call-with-output-string (lambda (port) (display val port))) (if (string? val) - "\"" - "")))) + "\"" + "")))) (define-public (!= lst r) (not (= lst r))) @@ -981,13 +981,13 @@ print a warning and set an optional @var{default}." (if (string? font) (string-downcase font) (let* ((font-name (ly:font-name font)) - (full-name (if font-name font-name (ly:font-file-name font)))) - (string-downcase full-name)))) + (full-name (if font-name font-name (ly:font-file-name font)))) + (string-downcase full-name)))) (define-public (modified-font-metric-font-scaling font) (let* ((designsize (ly:font-design-size font)) - (magnification (* (ly:font-magnification font))) - (scaling (* magnification designsize))) + (magnification (* (ly:font-magnification font))) + (scaling (* magnification designsize))) (debugf "scaling:~S\n" scaling) (debugf "magnification:~S\n" magnification) (debugf "design:~S\n" designsize) @@ -995,6 +995,6 @@ print a warning and set an optional @var{default}." (define-public (version-not-seen-message input-file-name) (ly:warning-located - (ly:format "~a:1" input-file-name) - (_ "no \\version statement found, please add~afor future compatibility") - (format #f "\n\n\\version ~s\n\n" (lilypond-version)))) + (ly:format "~a:1" input-file-name) + (_ "no \\version statement found, please add~afor future compatibility") + (format #f "\n\n\\version ~s\n\n" (lilypond-version)))) diff --git a/scm/lily-sort.scm b/scm/lily-sort.scm index 19fba423d4..95d3e33ffb 100644 --- a/scm/lily-sort.scm +++ b/scm/lily-sort.scm @@ -68,14 +68,14 @@ ((null? a) (cons #f (car b))) ((null? b) (cons (car a) #f)) ((not ((if ci char-ci=? char=?) (car a) (car b))) - (cons (car a) (car b))) + (cons (car a) (car b))) (else (find-mismatch (cdr a) (cdr b)))))) (define (ly:string-generic-<? a b ci) (let ((mismatch (first-diff-chars a b ci))) (cond ((and mismatch (car mismatch) (cdr mismatch)) - ((if ci ly:char-ci<? ly:char<?) - (car mismatch) (cdr mismatch))) + ((if ci ly:char-ci<? ly:char<?) + (car mismatch) (cdr mismatch))) ((and mismatch (cdr mismatch)) #t) (else #f)))) diff --git a/scm/lily.scm b/scm/lily.scm index 2028f1c20e..f227adc5b9 100644 --- a/scm/lily.scm +++ b/scm/lily.scm @@ -120,13 +120,13 @@ variables in the current module as well as those defined with ignore @var{thunk} and instead just reinitialize all recorded variables to their value after the initial call of @var{thunk}." -;; We need to save the variables of the current module along with -;; their values: functions defined in the module might refer to the -;; variables. + ;; We need to save the variables of the current module along with + ;; their values: functions defined in the module might refer to the + ;; variables. -;; The entries in lilypond-declarations consist of a cons* consisting -;; of symbol, variable, and value. Variables defined with -;; define-session have the symbol set to #f. + ;; The entries in lilypond-declarations consist of a cons* consisting + ;; of symbol, variable, and value. Variables defined with + ;; define-session have the symbol set to #f. (if (ly:undead? lilypond-declarations) (begin @@ -169,7 +169,7 @@ variables to their value after the initial call of @var{thunk}." ;; be longer than 48 characters per line. (anti-alias-factor 1 -"Render at higher resolution + "Render at higher resolution (using given factor) and scale down result to prevent jaggies in PNG images.") (aux-files @@ -379,7 +379,7 @@ messages into errors.") (scm clip-region) (scm memory-trace) (scm coverage) - (scm safe-utility-defs)) + (scm safe-utility-defs)) (define-public _ gettext) ;;; There are new modules defined in Guile V2.0 which we need to use. @@ -389,11 +389,11 @@ messages into errors.") ;; (cond - ((guile-v2) - (ly:debug (_ "Using (ice-9 curried-definitions) module\n")) - (use-modules (ice-9 curried-definitions))) - (else - (ly:debug (_ "Guile 1.8\n")))) + ((guile-v2) + (ly:debug (_ "Using (ice-9 curried-definitions) module\n")) + (use-modules (ice-9 curried-definitions))) + (else + (ly:debug (_ "Guile 1.8\n")))) ;; TODO add in modules for V1.8.7 deprecated in V2.0 and integrated ;; into Guile base code, like (ice-9 syncase). @@ -469,8 +469,8 @@ messages into errors.") (if (string-index x #\\) x (string-regexp-substitute - "//*" "/" - (string-regexp-substitute "\\\\" "/" x)))) + "//*" "/" + (string-regexp-substitute "\\\\" "/" x)))) (define-public (ly-getcwd) (if (eq? PLATFORM 'windows) @@ -588,7 +588,7 @@ messages into errors.") "x11-color.scm")) ;; - Files to be loaded last (define init-scheme-files-tail -;; - must be after everything has been defined + ;; - must be after everything has been defined '("safe-lily.scm")) ;; ;; Now construct the load list @@ -643,7 +643,7 @@ messages into errors.") (define-public guile-predicates `((,hash-table? . "hash table") - )) + )) (define-public lilypond-scheme-predicates `((,boolean-or-symbol? . "boolean or symbol") @@ -777,10 +777,10 @@ messages into errors.") (lambda (a b) (< (object-address (car a)) (object-address (car b)))))) - (out-file-name (string-append - "gcstat-" (number->string gc-protect-stat-count) - ".scm")) - (outfile (open-file out-file-name "w"))) + (out-file-name (string-append + "gcstat-" (number->string gc-protect-stat-count) + ".scm")) + (outfile (open-file out-file-name "w"))) (set! gc-dumping #t) (ly:progress "Dumping GC statistics ~a...\n" out-file-name) (for-each (lambda (y) @@ -810,13 +810,13 @@ messages into errors.") (ly:set-option 'debug-gc-assert-parsed-dead #t) (gc) (ly:set-option 'debug-gc-assert-parsed-dead #f) - (for-each - (lambda (x) - (if (not (hashq-ref gc-zombies x)) - (begin - (ly:programming-error "Parsed object should be dead: ~a" x) - (hashq-set! gc-zombies x #t)))) - (ly:parsed-undead-list!)) + (for-each + (lambda (x) + (if (not (hashq-ref gc-zombies x)) + (begin + (ly:programming-error "Parsed object should be dead: ~a" x) + (hashq-set! gc-zombies x #t)))) + (ly:parsed-undead-list!)) (set! stats (gc-live-object-stats)) (ly:progress "Dumping live object statistics.\n") (dump-live-object-stats outfile))) @@ -862,9 +862,9 @@ PIDs or the number of the process." (define (helper count acc) (if (> count 0) (let* ((pid (primitive-fork))) - (if (= pid 0) - (1- count) - (helper (1- count) (cons pid acc)))) + (if (= pid 0) + (1- count) + (helper (1- count) (cons pid acc)))) acc)) (helper count '())) @@ -916,7 +916,7 @@ PIDs or the number of the process." (begin (ly:set-option 'log-file (format #f "~a-~a" (ly:get-option 'log-file) joblist)) - (set! files (vector-ref split-todo joblist))) + (set! files (vector-ref split-todo joblist))) (begin (ly:progress "\nForking into jobs: ~a\n" joblist) (for-each (lambda (pid) @@ -924,7 +924,7 @@ PIDs or the number of the process." (if (not (= stat 0)) (set! errors (acons (list-element-index joblist pid) - stat errors))))) + stat errors))))) joblist) (for-each (lambda (x) @@ -943,17 +943,17 @@ PIDs or the number of the process." (ly:message (_ "logfile ~a (exit ~a):\n~a") logfile (status:exit-val state) tail)))) - errors) - (if (pair? errors) - (ly:error "Children ~a exited with errors." - (map car errors))) - ;; must overwrite individual entries - (if (ly:get-option 'dump-profile) - (dump-profile "lily-run-total" - '(0 0) (profile-measurements))) - (if (null? errors) - (ly:exit 0 #f) - (ly:exit 1 #f)))))) + errors) + (if (pair? errors) + (ly:error "Children ~a exited with errors." + (map car errors))) + ;; must overwrite individual entries + (if (ly:get-option 'dump-profile) + (dump-profile "lily-run-total" + '(0 0) (profile-measurements))) + (if (null? errors) + (ly:exit 0 #f) + (ly:exit 1 #f)))))) (if (string-or-symbol? (ly:get-option 'log-file)) (ly:stderr-redirect (format #f "~a.log" (ly:get-option 'log-file)) "w")) diff --git a/scm/ly-syntax-constructors.scm b/scm/ly-syntax-constructors.scm index 7817ec25c5..5f1583589b 100644 --- a/scm/ly-syntax-constructors.scm +++ b/scm/ly-syntax-constructors.scm @@ -35,9 +35,9 @@ ;; report errors. (defmacro define-ly-syntax-simple (args . body) `(define-public ,(cons* (car args) - 'parser - 'location - (cdr args)) + 'parser + 'location + (cdr args)) (let ((m ,(cons 'begin body))) (set! (ly:music-property m 'origin) location) m))) @@ -51,29 +51,29 @@ ;; fallback. (define-ly-syntax (music-function parser loc fun args . rest) (let* ((sig (ly:music-function-signature fun)) - (pred (if (pair? (car sig)) (caar sig) (car sig))) - (good (proper-list? args)) - (m (and good (apply (ly:music-function-extract fun) - parser loc (reverse! args rest))))) + (pred (if (pair? (car sig)) (caar sig) (car sig))) + (good (proper-list? args)) + (m (and good (apply (ly:music-function-extract fun) + parser loc (reverse! args rest))))) (if (and good (pred m)) - (begin - (if (ly:music? m) - (set! (ly:music-property m 'origin) loc)) - m) - (begin - (if good - (ly:parser-error parser - (format #f (_ "~a function cannot return ~a") - (type-name pred) m) - loc)) - (and (pair? (car sig)) (cdar sig)))))) + (begin + (if (ly:music? m) + (set! (ly:music-property m 'origin) loc)) + m) + (begin + (if good + (ly:parser-error parser + (format #f (_ "~a function cannot return ~a") + (type-name pred) m) + loc)) + (and (pair? (car sig)) (cdar sig)))))) (define-ly-syntax (argument-error parser location n pred arg) (ly:parser-error parser (format #f - (_ "wrong type for argument ~a. Expecting ~a, found ~s") - n (type-name pred) arg) + (_ "wrong type for argument ~a. Expecting ~a, found ~s") + n (type-name pred) arg) location)) (define-ly-syntax-simple (void-music) @@ -87,16 +87,16 @@ (define-ly-syntax-simple (event-chord mlist) (make-music 'EventChord - 'elements mlist)) + 'elements mlist)) (define-ly-syntax-simple (unrelativable-music mus) (make-music 'UnrelativableMusic - 'element mus)) + 'element mus)) (define-ly-syntax-simple (context-change type id) (make-music 'ContextChange - 'change-to-type type - 'change-to-id id)) + 'change-to-type type + 'change-to-id id)) (define-ly-syntax-simple (voice-separator) (make-music 'VoiceSeparator)) @@ -106,32 +106,32 @@ (define-ly-syntax (tempo parser location text . rest) (let* ((unit (and (pair? rest) - (car rest))) - (count (and unit - (cadr rest))) - (range-tempo? (pair? count)) - (tempo-change (make-music 'TempoChangeEvent - 'origin location - 'text text - 'tempo-unit unit - 'metronome-count count)) - (tempo-set - (and unit - (context-spec-music - (make-property-set 'tempoWholesPerMinute - (ly:moment-mul - (ly:make-moment - (if range-tempo? - (round (/ (+ (car count) (cdr count)) - 2)) - count) - 1) - (ly:duration-length unit))) - 'Score)))) + (car rest))) + (count (and unit + (cadr rest))) + (range-tempo? (pair? count)) + (tempo-change (make-music 'TempoChangeEvent + 'origin location + 'text text + 'tempo-unit unit + 'metronome-count count)) + (tempo-set + (and unit + (context-spec-music + (make-property-set 'tempoWholesPerMinute + (ly:moment-mul + (ly:make-moment + (if range-tempo? + (round (/ (+ (car count) (cdr count)) + 2)) + count) + 1) + (ly:duration-length unit))) + 'Score)))) (if tempo-set - (make-sequential-music (list tempo-change tempo-set)) - tempo-change))) + (make-sequential-music (list tempo-change tempo-set)) + tempo-change))) (define-ly-syntax-simple (repeat type num body alts) (make-repeat type num body alts)) @@ -142,35 +142,35 @@ into a @code{MultiMeasureTextEvent}." (if (memq 'script-event (ly:music-property music 'types)) (apply make-music 'MultiMeasureTextEvent - (flatten-alist (ly:music-mutable-properties music))) + (flatten-alist (ly:music-mutable-properties music))) music)) (define-ly-syntax (multi-measure-rest parser location duration articulations) (make-music 'MultiMeasureRestMusic - 'articulations (map script-to-mmrest-text articulations) - 'duration duration - 'origin location)) + 'articulations (map script-to-mmrest-text articulations) + 'duration duration + 'origin location)) (define-ly-syntax (repetition-chord parser location duration articulations) (make-music 'EventChord - 'duration duration - 'elements articulations - 'origin location)) + 'duration duration + 'elements articulations + 'origin location)) (define-ly-syntax-simple (context-specification type id ops create-new mus) (let* ((type-sym (if (symbol? type) type (string->symbol type))) - (csm (context-spec-music mus type-sym id))) + (csm (context-spec-music mus type-sym id))) (set! (ly:music-property csm 'property-operations) ops) (if create-new (set! (ly:music-property csm 'create-new) #t)) csm)) (define-ly-syntax (composed-markup-list parser location commands markups) -;; `markups' being a list of markups, eg (markup1 markup2 markup3), -;; and `commands' a list of commands with their scheme arguments, in reverse order, -;; eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg: -;; ((bold (raise 4 (italic markup1))) -;; (bold (raise 4 (italic markup2))) -;; (bold (raise 4 (italic markup3)))) + ;; `markups' being a list of markups, eg (markup1 markup2 markup3), + ;; and `commands' a list of commands with their scheme arguments, in reverse order, + ;; eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg: + ;; ((bold (raise 4 (italic markup1))) + ;; (bold (raise 4 (italic markup2))) + ;; (bold (raise 4 (italic markup3)))) (define (compose arg) (fold @@ -193,37 +193,37 @@ into a @code{MultiMeasureTextEvent}." (define-ly-syntax (property-operation parser location ctx music-type symbol . args) (let* ((props (case music-type - ((PropertySet) (list 'value (car args))) - ((PropertyUnset) '()) - ((OverrideProperty) (list 'grob-value (car args) - 'grob-property-path (if (list? (cadr args)) - (cadr args) - (cdr args)) - 'pop-first #t)) - ((RevertProperty) - (if (list? (car args)) - (list 'grob-property-path (car args)) - (list 'grob-property-path args))) - (else (ly:error (_ "Invalid property operation ~a") music-type)))) - (m (apply make-music music-type - 'symbol symbol - 'origin location - props))) + ((PropertySet) (list 'value (car args))) + ((PropertyUnset) '()) + ((OverrideProperty) (list 'grob-value (car args) + 'grob-property-path (if (list? (cadr args)) + (cadr args) + (cdr args)) + 'pop-first #t)) + ((RevertProperty) + (if (list? (car args)) + (list 'grob-property-path (car args)) + (list 'grob-property-path args))) + (else (ly:error (_ "Invalid property operation ~a") music-type)))) + (m (apply make-music music-type + 'symbol symbol + 'origin location + props))) (make-music 'ContextSpeccedMusic - 'element m - 'context-type ctx - 'origin location))) + 'element m + 'context-type ctx + 'origin location))) ;; TODO: It seems that this function rarely returns anything useful. (define (get-first-context-id type mus) "Find the name of a ContextSpeccedMusic with given type" (let ((id (ly:music-property mus 'context-id))) (if (and (eq? (ly:music-property mus 'type) 'ContextSpeccedMusic) - (eq? (ly:music-property mus 'context-type) type) - (string? id) - (not (string-null? id))) - id - '()))) + (eq? (ly:music-property mus 'context-type) type) + (string? id) + (not (string-null? id))) + id + '()))) (define unique-counter -1) (define (get-next-unique-voice-name) @@ -238,34 +238,34 @@ into a @code{MultiMeasureTextEvent}." ;; to signal to the Extender_engraver that any pending extender should ;; be completed if the lyrics end before the associated voice. (append! (ly:music-property music 'elements) - (list (make-music 'CompletizeExtenderEvent))) + (list (make-music 'CompletizeExtenderEvent))) (make-music 'LyricCombineMusic - 'element music - 'associated-context sync - 'origin loc)) + 'element music + 'associated-context sync + 'origin loc)) (define-ly-syntax (lyric-combine parser location voice music) (lyric-combine-music voice music location)) (define-ly-syntax (add-lyrics parser location music addlyrics-list) (let* ((existing-voice-name (get-first-context-id 'Voice music)) - (voice-name (if (string? existing-voice-name) - existing-voice-name - (get-next-unique-voice-name))) - (voice (if (string? existing-voice-name) - (music) - (make-music 'ContextSpeccedMusic - 'element music - 'context-type 'Voice - 'context-id voice-name - 'origin (ly:music-property music 'origin)))) - (lyricstos (map (lambda (mus) - (let* ((loc (ly:music-property mus 'origin)) - (lyr (lyric-combine-music voice-name mus loc))) - (make-music 'ContextSpeccedMusic - 'create-new #t - 'context-type 'Lyrics - 'element lyr - 'origin loc))) - addlyrics-list))) + (voice-name (if (string? existing-voice-name) + existing-voice-name + (get-next-unique-voice-name))) + (voice (if (string? existing-voice-name) + (music) + (make-music 'ContextSpeccedMusic + 'element music + 'context-type 'Voice + 'context-id voice-name + 'origin (ly:music-property music 'origin)))) + (lyricstos (map (lambda (mus) + (let* ((loc (ly:music-property mus 'origin)) + (lyr (lyric-combine-music voice-name mus loc))) + (make-music 'ContextSpeccedMusic + 'create-new #t + 'context-type 'Lyrics + 'element lyr + 'origin loc))) + addlyrics-list))) (make-simultaneous-music (cons voice lyricstos)))) diff --git a/scm/markup-macros.scm b/scm/markup-macros.scm index 07194407c5..72b107f846 100644 --- a/scm/markup-macros.scm +++ b/scm/markup-macros.scm @@ -147,7 +147,7 @@ command. There is no protection against circular definitions. ((not (null? (cdr prop-spec))) `(list ',(car prop-spec) ,(cadr prop-spec))) (else - `(list ',(car prop-spec))))) + `(list ',(car prop-spec))))) (if (pair? args) properties (list))))) @@ -197,7 +197,7 @@ interpreted, returns a list of stencils instead of a single one" ((not (null? (cdr prop-spec))) `(list ',(car prop-spec) ,(cadr prop-spec))) (else - `(list ',(car prop-spec))))) + `(list ',(car prop-spec))))) (if (pair? args) properties (list))))) @@ -384,10 +384,10 @@ against SIGNATURE, reporting MAKE-NAME as the user-invoked function. (set! args (cons `(list ,@(compile-all-markup-expressions (car rest))) args)) (set! rest (cdr rest))) (else - ;; pick up one arg in `rest' - (receive (a r) (compile-markup-arg rest) - (set! args (cons a args)) - (set! rest r)))))))) + ;; pick up one arg in `rest' + (receive (a r) (compile-markup-arg rest) + (set! args (cons a args)) + (set! rest r)))))))) ((and (pair? expr) (pair? (car expr)) (keyword? (caar expr))) @@ -398,9 +398,9 @@ against SIGNATURE, reporting MAKE-NAME as the user-invoked function. (string? (car expr))) ;; expr === ("string" ...) (values `(make-simple-markup ,(car expr)) (cdr expr))) (else - ;; expr === (symbol ...) or ((funcall ...) ...) - (values (car expr) - (cdr expr))))) + ;; expr === (symbol ...) or ((funcall ...) ...) + (values (car expr) + (cdr expr))))) (define (compile-all-markup-args expr) "Transform `expr' into markup arguments" diff --git a/scm/markup.scm b/scm/markup.scm index 45652c0a5c..69a6ad13ff 100644 --- a/scm/markup.scm +++ b/scm/markup.scm @@ -72,72 +72,72 @@ following stencil. Stencils with empty Y extent are not given ;;; convert a full markup object to an approximate pure string representation (define-public (markup->string m . argscopes) -(let* ((scopes (if (pair? argscopes) (car argscopes) '()))) - ;; markup commands with one markup argument, formatting ignored - (define markups-first-argument '(list - bold-markup box-markup caps-markup dynamic-markup finger-markup - fontCaps-markup huge-markup italic-markup large-markup larger-markup - medium-markup normal-size-sub-markup normal-size-super-markup - normal-text-markup normalsize-markup number-markup roman-markup - sans-markup simple-markup small-markup smallCaps-markup smaller-markup - sub-markup super-markup teeny-markup text-markup tiny-markup - typewriter-markup underline-markup upright-markup bracket-markup - circle-markup hbracket-markup parenthesize-markup rounded-box-markup - - center-align-markup center-column-markup column-markup dir-column-markup - fill-line-markup justify-markup justify-string-markup left-align-markup - left-column-markup line-markup right-align-markup right-column-markup - vcenter-markup wordwrap-markup wordwrap-string-markup )) - - ;; markup commands with markup as second argument, first argument - ;; specifies some formatting and is ignored - (define markups-second-argument '(list - abs-fontsize-markup fontsize-markup magnify-markup lower-markup - pad-around-markup pad-markup-markup pad-x-markup raise-markup - halign-markup hcenter-in-markup rotate-markup translate-markup - translate-scaled-markup with-url-markup scale-markup )) - - ;; helper functions to handle string cons like string lists - (define (markup-cons->string-cons c scopes) - (if (not (pair? c)) (markup->string c scopes) - (cons (markup->string (car c) scopes) (markup-cons->string-cons (cdr c) scopes)))) - (define (string-cons-join c) - (if (not (pair? c)) c - (string-join (list (car c) (string-cons-join (cdr c))) ""))) - - (cond - ((string? m) m) - ((null? m) "") - ((not (pair? m)) "") - - ;; handle \concat (string-join without spaces) - ((and (pair? m) (equal? (car m) concat-markup)) - (string-cons-join (markup-cons->string-cons (cadr m) scopes)) ) - - ;; markup functions with the markup as first arg - ((member (car m) (primitive-eval markups-first-argument)) - (markup->string (cadr m) scopes)) - - ;; markup functions with markup as second arg - ((member (car m) (primitive-eval markups-second-argument)) - (markup->string (cddr m) scopes)) - - ;; fromproperty-markup reads property values from the header block: - ((equal? (car m) fromproperty-markup) - (let* ((varname (symbol->string (cadr m))) - ;; cut off the header: prefix from the variable name: - (newvarname (if (string-prefix? "header:" varname) (substring varname 7) varname)) - (var (string->symbol newvarname)) - (mod (make-module 1))) - ;; Prevent loops by temporarily clearing the variable we have just looked up - (module-define! mod var "") - (markup->string (ly:modules-lookup scopes var) (cons mod scopes)))) - - ;; ignore all other markup functions - ((markup-function? (car m)) "") - - ;; handle markup lists - ((list? m) - (string-join (map (lambda (mm) (markup->string mm scopes)) m) " ")) - - (else "ERROR, unable to extract string from markup")))) + (let* ((scopes (if (pair? argscopes) (car argscopes) '()))) + ;; markup commands with one markup argument, formatting ignored + (define markups-first-argument '(list + bold-markup box-markup caps-markup dynamic-markup finger-markup + fontCaps-markup huge-markup italic-markup large-markup larger-markup + medium-markup normal-size-sub-markup normal-size-super-markup + normal-text-markup normalsize-markup number-markup roman-markup + sans-markup simple-markup small-markup smallCaps-markup smaller-markup + sub-markup super-markup teeny-markup text-markup tiny-markup + typewriter-markup underline-markup upright-markup bracket-markup + circle-markup hbracket-markup parenthesize-markup rounded-box-markup + + center-align-markup center-column-markup column-markup dir-column-markup + fill-line-markup justify-markup justify-string-markup left-align-markup + left-column-markup line-markup right-align-markup right-column-markup + vcenter-markup wordwrap-markup wordwrap-string-markup )) + + ;; markup commands with markup as second argument, first argument + ;; specifies some formatting and is ignored + (define markups-second-argument '(list + abs-fontsize-markup fontsize-markup magnify-markup lower-markup + pad-around-markup pad-markup-markup pad-x-markup raise-markup + halign-markup hcenter-in-markup rotate-markup translate-markup + translate-scaled-markup with-url-markup scale-markup )) + + ;; helper functions to handle string cons like string lists + (define (markup-cons->string-cons c scopes) + (if (not (pair? c)) (markup->string c scopes) + (cons (markup->string (car c) scopes) (markup-cons->string-cons (cdr c) scopes)))) + (define (string-cons-join c) + (if (not (pair? c)) c + (string-join (list (car c) (string-cons-join (cdr c))) ""))) + + (cond + ((string? m) m) + ((null? m) "") + ((not (pair? m)) "") + + ;; handle \concat (string-join without spaces) + ((and (pair? m) (equal? (car m) concat-markup)) + (string-cons-join (markup-cons->string-cons (cadr m) scopes)) ) + + ;; markup functions with the markup as first arg + ((member (car m) (primitive-eval markups-first-argument)) + (markup->string (cadr m) scopes)) + + ;; markup functions with markup as second arg + ((member (car m) (primitive-eval markups-second-argument)) + (markup->string (cddr m) scopes)) + + ;; fromproperty-markup reads property values from the header block: + ((equal? (car m) fromproperty-markup) + (let* ((varname (symbol->string (cadr m))) + ;; cut off the header: prefix from the variable name: + (newvarname (if (string-prefix? "header:" varname) (substring varname 7) varname)) + (var (string->symbol newvarname)) + (mod (make-module 1))) + ;; Prevent loops by temporarily clearing the variable we have just looked up + (module-define! mod var "") + (markup->string (ly:modules-lookup scopes var) (cons mod scopes)))) + + ;; ignore all other markup functions + ((markup-function? (car m)) "") + + ;; handle markup lists + ((list? m) + (string-join (map (lambda (mm) (markup->string mm scopes)) m) " ")) + + (else "ERROR, unable to extract string from markup")))) diff --git a/scm/memory-trace.scm b/scm/memory-trace.scm index 345d1327f0..293aca61e4 100644 --- a/scm/memory-trace.scm +++ b/scm/memory-trace.scm @@ -2,7 +2,7 @@ (define-module (scm memory-trace)) (use-modules (lily) - (ice-9 format)) + (ice-9 format)) (define-public (mtrace:start-trace freq) (set! usecond-interval (inexact->exact (/ 1000000 freq))) @@ -26,41 +26,41 @@ (define usecond-interval 100000) (define (arg-procedure args) (if (and (pair? args) - (pair? (cdr args)) - (pair? (cadr args))) + (pair? (cdr args)) + (pair? (cadr args))) (caadr args) #f)) (define last-count 0) (define (record-stack key continuation . args) (if (eq? (current-thread) trace-thread) #t ;; do nothing. (let* - ((cells (assoc-get 'total-cells-allocated (gc-stats))) - (proc (arg-procedure args)) - (time (tms:utime (times))) - (stack (extract-trace continuation))) - - (set! busy-tracing #t) - (trap-disable 'traps) - (trap-disable 'enter-frame) - - (set! trace-count (1+ trace-count)) - (ly:progress "<~a: ~a/~a>\n" - trace-count - (- time start-time) - (- cells last-count)) - - (set! last-count cells) - (set! trace-points - (cons (list - (cons 'cells cells) - (cons 'proc proc) - (cons 'stack stack) - (cons 'time time) - ) - - trace-points)) - - (set! busy-tracing #f)))) + ((cells (assoc-get 'total-cells-allocated (gc-stats))) + (proc (arg-procedure args)) + (time (tms:utime (times))) + (stack (extract-trace continuation))) + + (set! busy-tracing #t) + (trap-disable 'traps) + (trap-disable 'enter-frame) + + (set! trace-count (1+ trace-count)) + (ly:progress "<~a: ~a/~a>\n" + trace-count + (- time start-time) + (- cells last-count)) + + (set! last-count cells) + (set! trace-points + (cons (list + (cons 'cells cells) + (cons 'proc proc) + (cons 'stack stack) + (cons 'time time) + ) + + trace-points)) + + (set! busy-tracing #f)))) (define (start-install-tracepoint) (set! trace-thread (current-thread)) @@ -69,17 +69,17 @@ (set! trace-count 0) (set! start-memory (assoc-get 'total-cells-allocated (gc-stats))) (set! start-time (tms:utime (times))) - + (install-tracepoint)) (define (install-tracepoint) (if busy-tracing (display "last trace not finished yet\n" (current-error-port)) (begin - (trap-set! enter-frame-handler record-stack) - (trap-enable 'enter-frame) - (trap-enable 'traps))) - + (trap-set! enter-frame-handler record-stack) + (trap-enable 'enter-frame) + (trap-enable 'traps))) + (usleep usecond-interval) (if continue-tracing (install-tracepoint))) @@ -95,33 +95,33 @@ ) (ly:progress "Memory statistics to ~a and ~a..." - stacks-name graph-name) + stacks-name graph-name) (format graph-out "# memory trace with ~a points\n" (length trace-points)) (for-each (lambda (r) (let* - ((mem (- (assoc-get 'cells r) start-memory)) - (proc (assoc-get 'proc r)) - (stack (assoc-get 'stack r)) - (time (- (assoc-get 'time r) start-time))) - - (format graph-out "~a ~a\n" time mem) - (if stack - (begin - (format stacks-out "~5a t = ~5a - delta-mem: ~15a - ~a\n" i - time - (- mem last-mem) proc) - (do - ((j 0 (1+ j)) - (stack (assoc-get 'stack r) stack)) - ((>= j (vector-length stack))) - - (format stacks-out "\t~a\n" - (vector-ref stack j))))) - - (set! i (1+ i)) - (set! last-mem mem) - )) + ((mem (- (assoc-get 'cells r) start-memory)) + (proc (assoc-get 'proc r)) + (stack (assoc-get 'stack r)) + (time (- (assoc-get 'time r) start-time))) + + (format graph-out "~a ~a\n" time mem) + (if stack + (begin + (format stacks-out "~5a t = ~5a - delta-mem: ~15a - ~a\n" i + time + (- mem last-mem) proc) + (do + ((j 0 (1+ j)) + (stack (assoc-get 'stack r) stack)) + ((>= j (vector-length stack))) + + (format stacks-out "\t~a\n" + (vector-ref stack j))))) + + (set! i (1+ i)) + (set! last-mem mem) + )) (reverse trace-points)))) @@ -140,20 +140,20 @@ (trace (make-vector depth #f))) (do - ((i 0 (1+ i))) - ((>= i depth)) + ((i 0 (1+ i))) + ((>= i depth)) (vector-set! trace i (let* - ((source (frame-source (stack-ref stack i)))) + ((source (frame-source (stack-ref stack i)))) - (and source - (cons (source-property source 'filename) - (source-property source 'line)))))) + (and source + (cons (source-property source 'filename) + (source-property source 'line)))))) trace)) - - + + diff --git a/scm/midi.scm b/scm/midi.scm index 4807992822..e673555d93 100644 --- a/scm/midi.scm +++ b/scm/midi.scm @@ -27,20 +27,20 @@ (set! absolute-volume-alist (append '( - ("sf" . 1.00) - ("fffff" . 0.95) - ("ffff" . 0.92) - ("fff" . 0.85) - ("ff" . 0.80) - ("f" . 0.75) - ("mf" . 0.68) - ("mp" . 0.61) - ("p" . 0.55) - ("pp" . 0.49) - ("ppp" . 0.42) - ("pppp" . 0.34) - ("ppppp" . 0.25) - ) + ("sf" . 1.00) + ("fffff" . 0.95) + ("ffff" . 0.92) + ("fff" . 0.85) + ("ff" . 0.80) + ("f" . 0.75) + ("mf" . 0.68) + ("mp" . 0.61) + ("p" . 0.55) + ("pp" . 0.49) + ("ppp" . 0.42) + ("pppp" . 0.34) + ("ppppp" . 0.25) + ) absolute-volume-alist)) (define-public (default-dynamic-absolute-volume s) @@ -51,18 +51,18 @@ (set! instrument-equalizer-alist (append '( - ("flute" . (0 . 0.7)) - ("oboe" . (0 . 0.7)) - ("clarinet" . (0 . 0.7)) - ("bassoon" . (0 . 0.6)) - ("french horn" . (0.1 . 0.7)) - ("trumpet" . (0.1 . 0.8)) - ("timpani" . (0.2 . 0.9)) - ("violin" . (0.2 . 1.0)) - ("viola" . (0.1 . 0.7)) - ("cello" . (0.2 . 0.8)) - ("contrabass" . (0.2 . 0.8)) - ) + ("flute" . (0 . 0.7)) + ("oboe" . (0 . 0.7)) + ("clarinet" . (0 . 0.7)) + ("bassoon" . (0 . 0.6)) + ("french horn" . (0.1 . 0.7)) + ("trumpet" . (0.1 . 0.8)) + ("timpani" . (0.2 . 0.9)) + ("violin" . (0.2 . 1.0)) + ("viola" . (0.1 . 0.7)) + ("cello" . (0.2 . 0.8)) + ("contrabass" . (0.2 . 0.8)) + ) instrument-equalizer-alist)) (define-public (default-instrument-equalizer s) @@ -73,192 +73,192 @@ (set! instrument-names-alist (append `( - ("acoustic grand" . ,(- 1 1)) - ("bright acoustic" . ,(- 2 1)) - ("electric grand" . ,(- 3 1)) - ("honky-tonk" . ,(- 4 1)) - ("electric piano 1" . ,(- 5 1)) - ("electric piano 2" . ,(- 6 1)) - ("harpsichord" . ,(- 7 1)) - ("clav" . ,(- 8 1)) - - ;; (9-16 chrom percussion) - ("celesta" . ,(- 9 1)) - ("glockenspiel" . ,(- 10 1)) - ("music box" . ,(- 11 1)) - ("vibraphone" . ,(- 12 1)) - ("marimba" . ,(- 13 1)) - ("xylophone" . ,(- 14 1)) - ("tubular bells" . ,(- 15 1)) - ("dulcimer" . ,(- 16 1)) - - ;; (17-24 organ) - ("drawbar organ" . ,(- 17 1)) - ("percussive organ" . ,(- 18 1)) - ("rock organ" . ,(- 19 1)) - ("church organ" . ,(- 20 1)) - ("reed organ" . ,(- 21 1)) - ("accordion" . ,(- 22 1)) - ("harmonica" . ,(- 23 1)) - ("concertina" . ,(- 24 1)) - - ;; (25-32 guitar) - ("acoustic guitar (nylon)" . ,(- 25 1)) - ("acoustic guitar (steel)" . ,(- 26 1)) - ("electric guitar (jazz)" . ,(- 27 1)) - ("electric guitar (clean)" . ,(- 28 1)) - ("electric guitar (muted)" . ,(- 29 1)) - ("overdriven guitar" . ,(- 30 1)) - ("distorted guitar" . ,(- 31 1)) - ("guitar harmonics" . ,(- 32 1)) - - ;; (33-40 bass) - ("acoustic bass" . ,(- 33 1)) - ("electric bass (finger)" . ,(- 34 1)) - ("electric bass (pick)" . ,(- 35 1)) - ("fretless bass" . ,(- 36 1)) - ("slap bass 1" . ,(- 37 1)) - ("slap bass 2" . ,(- 38 1)) - ("synth bass 1" . ,(- 39 1)) - ("synth bass 2" . ,(- 40 1)) - - ;; (41-48 strings) - ("violin" . ,(- 41 1)) - ("viola" . ,(- 42 1)) - ("cello" . ,(- 43 1)) - ("contrabass" . ,(- 44 1)) - ("tremolo strings" . ,(- 45 1)) - ("pizzicato strings" . ,(- 46 1)) - ("orchestral harp" . ,(- 47 1)) - ("timpani" . ,(- 48 1)) - - ;; (49-56 ensemble) - ("string ensemble 1" . ,(- 49 1)) - ("string ensemble 2" . ,(- 50 1)) - ("synthstrings 1" . ,(- 51 1)) - ("synthstrings 2" . ,(- 52 1)) - ("choir aahs" . ,(- 53 1)) - ("voice oohs" . ,(- 54 1)) - ("synth voice" . ,(- 55 1)) - ("orchestra hit" . ,(- 56 1)) - - ;; (57-64 brass) - ("trumpet" . ,(- 57 1)) - ("trombone" . ,(- 58 1)) - ("tuba" . ,(- 59 1)) - ("muted trumpet" . ,(- 60 1)) - ("french horn" . ,(- 61 1)) - ("brass section" . ,(- 62 1)) - ("synthbrass 1" . ,(- 63 1)) - ("synthbrass 2" . ,(- 64 1)) - - ;; (65-72 reed) - ("soprano sax" . ,(- 65 1)) - ("alto sax" . ,(- 66 1)) - ("tenor sax" . ,(- 67 1)) - ("baritone sax" . ,(- 68 1)) - ("oboe" . ,(- 69 1)) - ("english horn" . ,(- 70 1)) - ("bassoon" . ,(- 71 1)) - ("clarinet" . ,(- 72 1)) - - ;; (73-80 pipe) - ("piccolo" . ,(- 73 1)) - ("flute" . ,(- 74 1)) - ("recorder" . ,(- 75 1)) - ("pan flute" . ,(- 76 1)) - ("blown bottle" . ,(- 77 1)) - ("shakuhachi" . ,(- 78 1)) - ("whistle" . ,(- 79 1)) - ("ocarina" . ,(- 80 1)) - - ;; (81-88 synth lead) - ("lead 1 (square)" . ,(- 81 1)) - ("lead 2 (sawtooth)" . ,(- 82 1)) - ("lead 3 (calliope)" . ,(- 83 1)) - ("lead 4 (chiff)" . ,(- 84 1)) - ("lead 5 (charang)" . ,(- 85 1)) - ("lead 6 (voice)" . ,(- 86 1)) - ("lead 7 (fifths)" . ,(- 87 1)) - ("lead 8 (bass+lead)" . ,(- 88 1)) - - ;; (89-96 synth pad) - ("pad 1 (new age)" . ,(- 89 1)) - ("pad 2 (warm)" . ,(- 90 1)) - ("pad 3 (polysynth)" . ,(- 91 1)) - ("pad 4 (choir)" . ,(- 92 1)) - ("pad 5 (bowed)" . ,(- 93 1)) - ("pad 6 (metallic)" . ,(- 94 1)) - ("pad 7 (halo)" . ,(- 95 1)) - ("pad 8 (sweep)" . ,(- 96 1)) - - ;; (97-104 synth effects) - ("fx 1 (rain)" . ,(- 97 1)) - ("fx 2 (soundtrack)" . ,(- 98 1)) - ("fx 3 (crystal)" . ,(- 99 1)) - ("fx 4 (atmosphere)" . ,(- 100 1)) - ("fx 5 (brightness)" . ,(- 101 1)) - ("fx 6 (goblins)" . ,(- 102 1)) - ("fx 7 (echoes)" . ,(- 103 1)) - ("fx 8 (sci-fi)" . ,(- 104 1)) - - ;; (105-112 ethnic) - ("sitar" . ,(- 105 1)) - ("banjo" . ,(- 106 1)) - ("shamisen" . ,(- 107 1)) - ("koto" . ,(- 108 1)) - ("kalimba" . ,(- 109 1)) - ("bagpipe" . ,(- 110 1)) - ("fiddle" . ,(- 111 1)) - ("shanai" . ,(- 112 1)) - - ;; (113-120 percussive) - ("tinkle bell" . ,(- 113 1)) - ("agogo" . ,(- 114 1)) - ("steel drums" . ,(- 115 1)) - ("woodblock" . ,(- 116 1)) - ("taiko drum" . ,(- 117 1)) - ("melodic tom" . ,(- 118 1)) - ("synth drum" . ,(- 119 1)) - ("reverse cymbal" . ,(- 120 1)) - - ;; (121-128 sound effects) - ("guitar fret noise" . ,(- 121 1)) - ("breath noise" . ,(- 122 1)) - ("seashore" . ,(- 123 1)) - ("bird tweet" . ,(- 124 1)) - ("telephone ring" . ,(- 125 1)) - ("helicopter" . ,(- 126 1)) - ("applause" . ,(- 127 1)) - ("gunshot" . ,(- 128 1)) - - ;; (channel 10 drum-kits - subtract 32768 to get program no.) - ("standard kit" . ,(+ 32768 0)) - ("standard drums" . ,(+ 32768 0)) - ("drums" . ,(+ 32768 0)) - ("room kit" . ,(+ 32768 8)) - ("room drums" . ,(+ 32768 8)) - ("power kit" . ,(+ 32768 16)) - ("power drums" . ,(+ 32768 16)) - ("rock drums" . ,(+ 32768 16)) - ("electronic kit" . ,(+ 32768 24)) - ("electronic drums" . ,(+ 32768 24)) - ("tr-808 kit" . ,(+ 32768 25)) - ("tr-808 drums" . ,(+ 32768 25)) - ("jazz kit" . ,(+ 32768 32)) - ("jazz drums" . ,(+ 32768 32)) - ("brush kit" . ,(+ 32768 40)) - ("brush drums" . ,(+ 32768 40)) - ("orchestra kit" . ,(+ 32768 48)) - ("orchestra drums" . ,(+ 32768 48)) - ("classical drums" . ,(+ 32768 48)) - ("sfx kit" . ,(+ 32768 56)) - ("sfx drums" . ,(+ 32768 56)) - ("mt-32 kit" . ,(+ 32768 127)) - ("mt-32 drums" . ,(+ 32768 127)) - ("cm-64 kit" . ,(+ 32768 127)) - ("cm-64 drums" . ,(+ 32768 127)) - ) + ("acoustic grand" . ,(- 1 1)) + ("bright acoustic" . ,(- 2 1)) + ("electric grand" . ,(- 3 1)) + ("honky-tonk" . ,(- 4 1)) + ("electric piano 1" . ,(- 5 1)) + ("electric piano 2" . ,(- 6 1)) + ("harpsichord" . ,(- 7 1)) + ("clav" . ,(- 8 1)) + + ;; (9-16 chrom percussion) + ("celesta" . ,(- 9 1)) + ("glockenspiel" . ,(- 10 1)) + ("music box" . ,(- 11 1)) + ("vibraphone" . ,(- 12 1)) + ("marimba" . ,(- 13 1)) + ("xylophone" . ,(- 14 1)) + ("tubular bells" . ,(- 15 1)) + ("dulcimer" . ,(- 16 1)) + + ;; (17-24 organ) + ("drawbar organ" . ,(- 17 1)) + ("percussive organ" . ,(- 18 1)) + ("rock organ" . ,(- 19 1)) + ("church organ" . ,(- 20 1)) + ("reed organ" . ,(- 21 1)) + ("accordion" . ,(- 22 1)) + ("harmonica" . ,(- 23 1)) + ("concertina" . ,(- 24 1)) + + ;; (25-32 guitar) + ("acoustic guitar (nylon)" . ,(- 25 1)) + ("acoustic guitar (steel)" . ,(- 26 1)) + ("electric guitar (jazz)" . ,(- 27 1)) + ("electric guitar (clean)" . ,(- 28 1)) + ("electric guitar (muted)" . ,(- 29 1)) + ("overdriven guitar" . ,(- 30 1)) + ("distorted guitar" . ,(- 31 1)) + ("guitar harmonics" . ,(- 32 1)) + + ;; (33-40 bass) + ("acoustic bass" . ,(- 33 1)) + ("electric bass (finger)" . ,(- 34 1)) + ("electric bass (pick)" . ,(- 35 1)) + ("fretless bass" . ,(- 36 1)) + ("slap bass 1" . ,(- 37 1)) + ("slap bass 2" . ,(- 38 1)) + ("synth bass 1" . ,(- 39 1)) + ("synth bass 2" . ,(- 40 1)) + + ;; (41-48 strings) + ("violin" . ,(- 41 1)) + ("viola" . ,(- 42 1)) + ("cello" . ,(- 43 1)) + ("contrabass" . ,(- 44 1)) + ("tremolo strings" . ,(- 45 1)) + ("pizzicato strings" . ,(- 46 1)) + ("orchestral harp" . ,(- 47 1)) + ("timpani" . ,(- 48 1)) + + ;; (49-56 ensemble) + ("string ensemble 1" . ,(- 49 1)) + ("string ensemble 2" . ,(- 50 1)) + ("synthstrings 1" . ,(- 51 1)) + ("synthstrings 2" . ,(- 52 1)) + ("choir aahs" . ,(- 53 1)) + ("voice oohs" . ,(- 54 1)) + ("synth voice" . ,(- 55 1)) + ("orchestra hit" . ,(- 56 1)) + + ;; (57-64 brass) + ("trumpet" . ,(- 57 1)) + ("trombone" . ,(- 58 1)) + ("tuba" . ,(- 59 1)) + ("muted trumpet" . ,(- 60 1)) + ("french horn" . ,(- 61 1)) + ("brass section" . ,(- 62 1)) + ("synthbrass 1" . ,(- 63 1)) + ("synthbrass 2" . ,(- 64 1)) + + ;; (65-72 reed) + ("soprano sax" . ,(- 65 1)) + ("alto sax" . ,(- 66 1)) + ("tenor sax" . ,(- 67 1)) + ("baritone sax" . ,(- 68 1)) + ("oboe" . ,(- 69 1)) + ("english horn" . ,(- 70 1)) + ("bassoon" . ,(- 71 1)) + ("clarinet" . ,(- 72 1)) + + ;; (73-80 pipe) + ("piccolo" . ,(- 73 1)) + ("flute" . ,(- 74 1)) + ("recorder" . ,(- 75 1)) + ("pan flute" . ,(- 76 1)) + ("blown bottle" . ,(- 77 1)) + ("shakuhachi" . ,(- 78 1)) + ("whistle" . ,(- 79 1)) + ("ocarina" . ,(- 80 1)) + + ;; (81-88 synth lead) + ("lead 1 (square)" . ,(- 81 1)) + ("lead 2 (sawtooth)" . ,(- 82 1)) + ("lead 3 (calliope)" . ,(- 83 1)) + ("lead 4 (chiff)" . ,(- 84 1)) + ("lead 5 (charang)" . ,(- 85 1)) + ("lead 6 (voice)" . ,(- 86 1)) + ("lead 7 (fifths)" . ,(- 87 1)) + ("lead 8 (bass+lead)" . ,(- 88 1)) + + ;; (89-96 synth pad) + ("pad 1 (new age)" . ,(- 89 1)) + ("pad 2 (warm)" . ,(- 90 1)) + ("pad 3 (polysynth)" . ,(- 91 1)) + ("pad 4 (choir)" . ,(- 92 1)) + ("pad 5 (bowed)" . ,(- 93 1)) + ("pad 6 (metallic)" . ,(- 94 1)) + ("pad 7 (halo)" . ,(- 95 1)) + ("pad 8 (sweep)" . ,(- 96 1)) + + ;; (97-104 synth effects) + ("fx 1 (rain)" . ,(- 97 1)) + ("fx 2 (soundtrack)" . ,(- 98 1)) + ("fx 3 (crystal)" . ,(- 99 1)) + ("fx 4 (atmosphere)" . ,(- 100 1)) + ("fx 5 (brightness)" . ,(- 101 1)) + ("fx 6 (goblins)" . ,(- 102 1)) + ("fx 7 (echoes)" . ,(- 103 1)) + ("fx 8 (sci-fi)" . ,(- 104 1)) + + ;; (105-112 ethnic) + ("sitar" . ,(- 105 1)) + ("banjo" . ,(- 106 1)) + ("shamisen" . ,(- 107 1)) + ("koto" . ,(- 108 1)) + ("kalimba" . ,(- 109 1)) + ("bagpipe" . ,(- 110 1)) + ("fiddle" . ,(- 111 1)) + ("shanai" . ,(- 112 1)) + + ;; (113-120 percussive) + ("tinkle bell" . ,(- 113 1)) + ("agogo" . ,(- 114 1)) + ("steel drums" . ,(- 115 1)) + ("woodblock" . ,(- 116 1)) + ("taiko drum" . ,(- 117 1)) + ("melodic tom" . ,(- 118 1)) + ("synth drum" . ,(- 119 1)) + ("reverse cymbal" . ,(- 120 1)) + + ;; (121-128 sound effects) + ("guitar fret noise" . ,(- 121 1)) + ("breath noise" . ,(- 122 1)) + ("seashore" . ,(- 123 1)) + ("bird tweet" . ,(- 124 1)) + ("telephone ring" . ,(- 125 1)) + ("helicopter" . ,(- 126 1)) + ("applause" . ,(- 127 1)) + ("gunshot" . ,(- 128 1)) + + ;; (channel 10 drum-kits - subtract 32768 to get program no.) + ("standard kit" . ,(+ 32768 0)) + ("standard drums" . ,(+ 32768 0)) + ("drums" . ,(+ 32768 0)) + ("room kit" . ,(+ 32768 8)) + ("room drums" . ,(+ 32768 8)) + ("power kit" . ,(+ 32768 16)) + ("power drums" . ,(+ 32768 16)) + ("rock drums" . ,(+ 32768 16)) + ("electronic kit" . ,(+ 32768 24)) + ("electronic drums" . ,(+ 32768 24)) + ("tr-808 kit" . ,(+ 32768 25)) + ("tr-808 drums" . ,(+ 32768 25)) + ("jazz kit" . ,(+ 32768 32)) + ("jazz drums" . ,(+ 32768 32)) + ("brush kit" . ,(+ 32768 40)) + ("brush drums" . ,(+ 32768 40)) + ("orchestra kit" . ,(+ 32768 48)) + ("orchestra drums" . ,(+ 32768 48)) + ("classical drums" . ,(+ 32768 48)) + ("sfx kit" . ,(+ 32768 56)) + ("sfx drums" . ,(+ 32768 56)) + ("mt-32 kit" . ,(+ 32768 127)) + ("mt-32 drums" . ,(+ 32768 127)) + ("cm-64 kit" . ,(+ 32768 127)) + ("cm-64 drums" . ,(+ 32768 127)) + ) instrument-names-alist)) (define-public (percussion? instrument) @@ -275,7 +275,7 @@ (entry (assoc-get inst instrument-names-alist))) (if entry (modulo entry 32768) - #f))) + #f))) ;; 90 == 90/127 == 0.71 is supposed to be the default value ;; urg: we should set this at start of track @@ -293,14 +293,14 @@ (define-public (write-performances-midis performances basename . rest) (let ((midi-ext (ly:get-option 'midi-extension))) (let - loop + loop ((perfs performances) (count (if (null? rest) 0 (car rest)))) (if (pair? perfs) - (begin - (ly:performance-write - (car perfs) - (if (> count 0) - (format #f "~a-~a.~a" basename count midi-ext) - (format #f "~a.~a" basename midi-ext))) - (loop (cdr perfs) (1+ count))))))) + (begin + (ly:performance-write + (car perfs) + (if (> count 0) + (format #f "~a-~a.~a" basename count midi-ext) + (format #f "~a.~a" basename midi-ext))) + (loop (cdr perfs) (1+ count))))))) diff --git a/scm/modal-transforms.scm b/scm/modal-transforms.scm index 9617329d77..3db3904726 100644 --- a/scm/modal-transforms.scm +++ b/scm/modal-transforms.scm @@ -48,11 +48,11 @@ pitches as members of a scale. (else (list-ref scale - (modulo - (+ (index pitch scale) - (- (index to-pitch scale) - (index from-pitch scale))) - (length scale))))))) + (modulo + (+ (index pitch scale) + (- (index to-pitch scale) + (index from-pitch scale))) + (length scale))))))) (define (inverter-factory scale) "Returns an inverter for the specified @var{scale}. @@ -81,11 +81,11 @@ arbitrary items and pitches as members of a scale. (else (list-ref scale - (modulo - (+ (index to-pitch scale) - (- (index around-pitch scale) - (index pitch scale))) - (length scale))))))) + (modulo + (+ (index to-pitch scale) + (- (index around-pitch scale) + (index pitch scale))) + (length scale))))))) (define (replicate-modify lis n mod-proc) "Apply @code{(mod-proc lis n)} to each element of a list and @@ -112,8 +112,8 @@ a single pitch as its argument and return a new pitch. These are LilyPond scheme pitches, e.g. @code{(ly:make-pitch 0 2 0)} " (let ((elements (ly:music-property music 'elements)) - (element (ly:music-property music 'element)) - (pitch (ly:music-property music 'pitch))) + (element (ly:music-property music 'element)) + (pitch (ly:music-property music 'pitch))) (cond ((ly:pitch? pitch) @@ -135,8 +135,8 @@ Typically used to construct a scale for input to transposer-factory " (let ((elements (ly:music-property music 'elements)) - (element (ly:music-property music 'element)) - (pitch (ly:music-property music 'pitch))) + (element (ly:music-property music 'element)) + (pitch (ly:music-property music 'pitch))) (cond ((ly:pitch? pitch) @@ -159,10 +159,10 @@ Typically used to construct a scale for input to transposer-factory (lambda (lis n) (map (lambda (i) - (ly:make-pitch - (+ (- n 6) (ly:pitch-octave i)) - (ly:pitch-notename i) - (ly:pitch-alteration i))) + (ly:make-pitch + (+ (- n 6) (ly:pitch-octave i)) + (ly:pitch-notename i) + (ly:pitch-alteration i))) lis))) (let ((scale (make-scale music))) @@ -215,11 +215,11 @@ Typically used to construct a scale for input to transposer-factory and transposes from @var{around} to @var{to}." (let ((p (ly:music-property music 'pitch))) (if (ly:pitch? p) - (ly:music-set-property! - music 'pitch - (ly:pitch-transpose to (ly:pitch-diff around p)))) + (ly:music-set-property! + music 'pitch + (ly:pitch-transpose to (ly:pitch-diff around p)))) music)) (define-public (music-invert around to music) "Applies pitch-invert to all pitches in @var{music}." - (music-map (lambda (x) (pitch-invert around to x)) music)) + (music-map (lambda (x) (pitch-invert around to x)) music)) diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 95d4c80f3c..5e07229a37 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -28,7 +28,7 @@ ;;; ==> set the 'elements property and return it (define-public ly:music-property (make-procedure-with-setter ly:music-property - ly:music-set-property!)) + ly:music-set-property!)) (define-safe-public (music-is-of-type? mus type) "Does @code{mus} belong to the music class @code{type}?" @@ -37,23 +37,23 @@ ;; TODO move this (define-public ly:grob-property (make-procedure-with-setter ly:grob-property - ly:grob-set-property!)) + ly:grob-set-property!)) (define-public ly:grob-object (make-procedure-with-setter ly:grob-object - ly:grob-set-object!)) + ly:grob-set-object!)) (define-public ly:grob-parent (make-procedure-with-setter ly:grob-parent - ly:grob-set-parent!)) + ly:grob-set-parent!)) (define-public ly:prob-property (make-procedure-with-setter ly:prob-property - ly:prob-set-property!)) + ly:prob-set-property!)) (define-public ly:context-property (make-procedure-with-setter ly:context-property - ly:context-set-property!)) + ly:context-set-property!)) (define-public (music-map function music) "Apply @var{function} to @var{music} and all of the music it contains. @@ -61,13 +61,13 @@ First it recurses over the children, then the function is applied to @var{music}." (let ((es (ly:music-property music 'elements)) - (e (ly:music-property music 'element))) + (e (ly:music-property music 'element))) (if (pair? es) - (set! (ly:music-property music 'elements) - (map (lambda (y) (music-map function y)) es))) + (set! (ly:music-property music 'elements) + (map (lambda (y) (music-map function y)) es))) (if (ly:music? e) - (set! (ly:music-property music 'element) - (music-map function e))) + (set! (ly:music-property music 'element) + (music-map function e))) (function music))) (define-public (music-filter pred? music) @@ -76,31 +76,31 @@ First it recurses over the children, then the function is applied to (define (inner-music-filter pred? music) "Recursive function." (let* ((es (ly:music-property music 'elements)) - (e (ly:music-property music 'element)) - (as (ly:music-property music 'articulations)) - (filtered-as (filter ly:music? (map (lambda (y) (inner-music-filter pred? y)) as))) - (filtered-e (if (ly:music? e) - (inner-music-filter pred? e) - e)) - (filtered-es (filter ly:music? (map (lambda (y) (inner-music-filter pred? y)) es)))) + (e (ly:music-property music 'element)) + (as (ly:music-property music 'articulations)) + (filtered-as (filter ly:music? (map (lambda (y) (inner-music-filter pred? y)) as))) + (filtered-e (if (ly:music? e) + (inner-music-filter pred? e) + e)) + (filtered-es (filter ly:music? (map (lambda (y) (inner-music-filter pred? y)) es)))) (if (not (null? e)) - (set! (ly:music-property music 'element) filtered-e)) + (set! (ly:music-property music 'element) filtered-e)) (if (not (null? es)) - (set! (ly:music-property music 'elements) filtered-es)) + (set! (ly:music-property music 'elements) filtered-es)) (if (not (null? as)) - (set! (ly:music-property music 'articulations) filtered-as)) + (set! (ly:music-property music 'articulations) filtered-as)) ;; if filtering emptied the expression, we remove it completely. (if (or (not (pred? music)) - (and (eq? filtered-es '()) (not (ly:music? e)) - (or (not (eq? es '())) - (ly:music? e)))) - (set! music '())) + (and (eq? filtered-es '()) (not (ly:music? e)) + (or (not (eq? es '())) + (ly:music? e)))) + (set! music '())) music)) (set! music (inner-music-filter pred? music)) (if (ly:music? music) music - (make-music 'Music))) ;must return music. + (make-music 'Music))) ;must return music. (define*-public (display-music music #:optional (port (current-output-port))) "Display music, not done with @code{music-map} for clarity of @@ -108,16 +108,16 @@ presentation." (display music port) (display ": { " port) (let ((es (ly:music-property music 'elements)) - (e (ly:music-property music 'element))) + (e (ly:music-property music 'element))) (display (ly:music-mutable-properties music) port) (if (pair? es) - (begin (display "\nElements: {\n" port) - (for-each (lambda (m) (display-music m port)) es) - (display "}\n" port))) + (begin (display "\nElements: {\n" port) + (for-each (lambda (m) (display-music m port)) es) + (display "}\n" port))) (if (ly:music? e) - (begin - (display "\nChild:" port) - (display-music e port)))) + (begin + (display "\nChild:" port) + (display-music e port)))) (display " }\n" port) music) @@ -134,20 +134,20 @@ For instance, "Return a keyword, eg. `#:bold', from the `proc' function, eg. #<procedure bold-markup (layout props arg)>" (let ((cmd-markup (symbol->string (procedure-name proc)))) (symbol->keyword (string->symbol (substring cmd-markup 0 (- (string-length cmd-markup) - (string-length "-markup"))))))) + (string-length "-markup"))))))) (define (transform-arg arg) (cond ((and (pair? arg) (markup? (car arg))) ;; a markup list - (apply append (map inner-markup->make-markup arg))) - ((and (not (string? arg)) (markup? arg)) ;; a markup - (inner-markup->make-markup arg)) - (else ;; scheme arg - (music->make-music arg)))) + (apply append (map inner-markup->make-markup arg))) + ((and (not (string? arg)) (markup? arg)) ;; a markup + (inner-markup->make-markup arg)) + (else ;; scheme arg + (music->make-music arg)))) (define (inner-markup->make-markup mrkup) (if (string? mrkup) - `(#:simple ,mrkup) - (let ((cmd (proc->command-keyword (car mrkup))) - (args (map transform-arg (cdr mrkup)))) - `(,cmd ,@args)))) + `(#:simple ,mrkup) + (let ((cmd (proc->command-keyword (car mrkup))) + (args (map transform-arg (cdr mrkup)))) + `(,cmd ,@args)))) ;; body: (if (string? markup-expression) markup-expression @@ -158,52 +158,52 @@ For instance, equivalent to @var{obj}, that is, for a music expression, a @code{(make-music ...)} form." (cond (;; markup expression - (markup? obj) - (markup-expression->make-markup obj)) - (;; music expression - (ly:music? obj) - `(make-music - ',(ly:music-property obj 'name) - ,@(apply append (map (lambda (prop) + (markup? obj) + (markup-expression->make-markup obj)) + (;; music expression + (ly:music? obj) + `(make-music + ',(ly:music-property obj 'name) + ,@(apply append (map (lambda (prop) `(',(car prop) - ,(music->make-music (cdr prop)))) + ,(music->make-music (cdr prop)))) (remove (lambda (prop) (eqv? (car prop) 'origin)) (ly:music-mutable-properties obj)))))) - (;; moment - (ly:moment? obj) - `(ly:make-moment ,(ly:moment-main-numerator obj) - ,(ly:moment-main-denominator obj) - ,(ly:moment-grace-numerator obj) - ,(ly:moment-grace-denominator obj))) - (;; note duration - (ly:duration? obj) - `(ly:make-duration ,(ly:duration-log obj) - ,(ly:duration-dot-count obj) - ,(ly:duration-scale obj))) - (;; note pitch - (ly:pitch? obj) - `(ly:make-pitch ,(ly:pitch-octave obj) - ,(ly:pitch-notename obj) - ,(ly:pitch-alteration obj))) - (;; scheme procedure - (procedure? obj) - (or (procedure-name obj) obj)) - (;; a symbol (avoid having an unquoted symbol) - (symbol? obj) - `',obj) - (;; an empty list (avoid having an unquoted empty list) - (null? obj) - `'()) - (;; a proper list - (list? obj) - `(list ,@(map music->make-music obj))) - (;; a pair - (pair? obj) - `(cons ,(music->make-music (car obj)) - ,(music->make-music (cdr obj)))) - (else - obj))) + (;; moment + (ly:moment? obj) + `(ly:make-moment ,(ly:moment-main-numerator obj) + ,(ly:moment-main-denominator obj) + ,(ly:moment-grace-numerator obj) + ,(ly:moment-grace-denominator obj))) + (;; note duration + (ly:duration? obj) + `(ly:make-duration ,(ly:duration-log obj) + ,(ly:duration-dot-count obj) + ,(ly:duration-scale obj))) + (;; note pitch + (ly:pitch? obj) + `(ly:make-pitch ,(ly:pitch-octave obj) + ,(ly:pitch-notename obj) + ,(ly:pitch-alteration obj))) + (;; scheme procedure + (procedure? obj) + (or (procedure-name obj) obj)) + (;; a symbol (avoid having an unquoted symbol) + (symbol? obj) + `',obj) + (;; an empty list (avoid having an unquoted empty list) + (null? obj) + `'()) + (;; a proper list + (list? obj) + `(list ,@(map music->make-music obj))) + (;; a pair + (pair? obj) + `(cons ,(music->make-music (car obj)) + ,(music->make-music (cdr obj)))) + (else + obj))) (use-modules (ice-9 pretty-print)) (define*-public (display-scheme-music obj #:optional (port (current-output-port))) @@ -219,14 +219,14 @@ which often can be read back in order to generate an equivalent expression." (scm display-lily)) (define*-public (display-lily-music expr parser #:optional (port (current-output-port)) - #:key force-duration) + #:key force-duration) "Display the music expression using LilyPond syntax" (memoize-clef-names supported-clefs) (parameterize ((*indent* 0) - (*previous-duration* (ly:make-duration 2)) - (*force-duration* force-duration)) - (display (music->lily-string expr parser) port) - (newline port))) + (*previous-duration* (ly:make-duration 2)) + (*force-duration* force-duration)) + (display (music->lily-string expr parser) port) + (newline port))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -236,17 +236,17 @@ which often can be read back in order to generate an equivalent expression." The number of dots in the shifted music may not be less than zero." (let ((d (ly:music-property music 'duration))) (if (ly:duration? d) - (let* ((cp (ly:duration-scale d)) - (nd (ly:make-duration + (let* ((cp (ly:duration-scale d)) + (nd (ly:make-duration (+ shift (ly:duration-log d)) (max 0 (+ dot (ly:duration-dot-count d))) - cp))) - (set! (ly:music-property music 'duration) nd))) + cp))) + (set! (ly:music-property music 'duration) nd))) music)) (define-public (shift-duration-log music shift dot) (music-map (lambda (x) (shift-one-duration-log x shift dot)) - music)) + music)) (define-public (make-repeat name times main alts) "Create a repeat music expression, with all properties initialized @@ -257,55 +257,55 @@ through MUSIC." ;; NoteEvent or a non-expanded chord-repetition ;; We just take anything that actually sports an announced duration. (if (ly:duration? (ly:music-property music 'duration)) - (ly:music-property music 'duration) - (let loop ((elts (if (ly:music? (ly:music-property music 'element)) - (list (ly:music-property music 'element)) - (ly:music-property music 'elements)))) - (and (pair? elts) - (let ((dur (first-note-duration (car elts)))) - (if (ly:duration? dur) - dur - (loop (cdr elts)))))))) + (ly:music-property music 'duration) + (let loop ((elts (if (ly:music? (ly:music-property music 'element)) + (list (ly:music-property music 'element)) + (ly:music-property music 'elements)))) + (and (pair? elts) + (let ((dur (first-note-duration (car elts)))) + (if (ly:duration? dur) + dur + (loop (cdr elts)))))))) (let ((talts (if (< times (length alts)) - (begin - (ly:warning (_ "More alternatives than repeats. Junking excess alternatives")) - (take alts times)) - alts)) - (r (make-repeated-music name))) + (begin + (ly:warning (_ "More alternatives than repeats. Junking excess alternatives")) + (take alts times)) + alts)) + (r (make-repeated-music name))) (set! (ly:music-property r 'element) main) (set! (ly:music-property r 'repeat-count) (max times 1)) (set! (ly:music-property r 'elements) talts) (if (and (equal? name "tremolo") - (pair? (extract-named-music main '(EventChord NoteEvent)))) - ;; This works for single-note and multi-note tremolos! - (let* ((children (if (music-is-of-type? main 'sequential-music) - ;; \repeat tremolo n { ... } - (length (extract-named-music main '(EventChord - NoteEvent))) - ;; \repeat tremolo n c4 - 1)) - ;; # of dots is equal to the 1 in bitwise representation (minus 1)! - (dots (1- (logcount (* times children)))) - ;; The remaining missing multiplicator to scale the notes by - ;; times * children - (mult (/ (* times children (ash 1 dots)) (1- (ash 2 dots)))) - (shift (- (ly:intlog2 (floor mult)))) - (note-duration (first-note-duration r)) - (duration-log (if (ly:duration? note-duration) - (ly:duration-log note-duration) - 1)) - (tremolo-type (ash 1 duration-log))) - (set! (ly:music-property r 'tremolo-type) tremolo-type) - (if (not (and (integer? mult) (= (logcount mult) 1))) - (ly:music-warning - main - (ly:format (_ "invalid tremolo repeat count: ~a") times))) - ;; Adjust the time of the notes - (ly:music-compress r (ly:make-moment 1 children)) - ;; Adjust the displayed note durations - (shift-duration-log r shift dots)) - r))) + (pair? (extract-named-music main '(EventChord NoteEvent)))) + ;; This works for single-note and multi-note tremolos! + (let* ((children (if (music-is-of-type? main 'sequential-music) + ;; \repeat tremolo n { ... } + (length (extract-named-music main '(EventChord + NoteEvent))) + ;; \repeat tremolo n c4 + 1)) + ;; # of dots is equal to the 1 in bitwise representation (minus 1)! + (dots (1- (logcount (* times children)))) + ;; The remaining missing multiplicator to scale the notes by + ;; times * children + (mult (/ (* times children (ash 1 dots)) (1- (ash 2 dots)))) + (shift (- (ly:intlog2 (floor mult)))) + (note-duration (first-note-duration r)) + (duration-log (if (ly:duration? note-duration) + (ly:duration-log note-duration) + 1)) + (tremolo-type (ash 1 duration-log))) + (set! (ly:music-property r 'tremolo-type) tremolo-type) + (if (not (and (integer? mult) (= (logcount mult) 1))) + (ly:music-warning + main + (ly:format (_ "invalid tremolo repeat count: ~a") times))) + ;; Adjust the time of the notes + (ly:music-compress r (ly:make-moment 1 children)) + ;; Adjust the displayed note durations + (shift-duration-log r shift dots)) + r))) (define (calc-repeat-slash-count music) "Given the child-list @var{music} in @code{PercentRepeatMusic}, @@ -313,13 +313,13 @@ calculate the number of slashes based on the durations. Returns @code{0} if durations in @var{music} vary, allowing slash beats and double-percent beats to be distinguished." (let* ((durs (map duration-of-note - (extract-named-music music '(EventChord NoteEvent - RestEvent SkipEvent)))) - (first-dur (car durs))) + (extract-named-music music '(EventChord NoteEvent + RestEvent SkipEvent)))) + (first-dur (car durs))) (if (every (lambda (d) (equal? d first-dur)) durs) - (max (- (ly:duration-log first-dur) 2) 1) - 0))) + (max (- (ly:duration-log first-dur) 2) 1) + 0))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; clusters. @@ -328,8 +328,8 @@ beats to be distinguished." "Replace @code{NoteEvents} by @code{ClusterNoteEvents}." (if (eq? (ly:music-property music 'name) 'NoteEvent) (make-music 'ClusterNoteEvent - 'pitch (ly:music-property music 'pitch) - 'duration (ly:music-property music 'duration)) + 'pitch (ly:music-property music 'pitch) + 'duration (ly:music-property music 'duration)) music)) (define-public (notes-to-clusters music) @@ -342,44 +342,44 @@ beats to be distinguished." "Replace all repeats with unfolded repeats." (let ((es (ly:music-property music 'elements)) - (e (ly:music-property music 'element))) + (e (ly:music-property music 'element))) (if (music-is-of-type? music 'repeated-music) - (let* ((props (ly:music-mutable-properties music)) - (old-name (ly:music-property music 'name)) - (flattened (flatten-alist props))) - (set! music (apply make-music (cons 'UnfoldedRepeatedMusic - flattened))) - - (if (and (equal? old-name 'TremoloRepeatedMusic) - (pair? (extract-named-music e '(EventChord NoteEvent)))) - ;; This works for single-note and multi-note tremolos! - (let* ((children (if (music-is-of-type? e 'sequential-music) - ;; \repeat tremolo n { ... } - (length (extract-named-music e '(EventChord - NoteEvent))) - ;; \repeat tremolo n c4 - 1)) - (times (ly:music-property music 'repeat-count)) - - ;; # of dots is equal to the 1 in bitwise representation (minus 1)! - (dots (1- (logcount (* times children)))) - ;; The remaining missing multiplicator to scale the notes by - ;; times * children - (mult (/ (* times children (ash 1 dots)) (1- (ash 2 dots)))) - (shift (- (ly:intlog2 (floor mult))))) - - ;; Adjust the time of the notes - (ly:music-compress music (ly:make-moment children 1)) - ;; Adjust the displayed note durations - (shift-duration-log music (- shift) (- dots)))))) + (let* ((props (ly:music-mutable-properties music)) + (old-name (ly:music-property music 'name)) + (flattened (flatten-alist props))) + (set! music (apply make-music (cons 'UnfoldedRepeatedMusic + flattened))) + + (if (and (equal? old-name 'TremoloRepeatedMusic) + (pair? (extract-named-music e '(EventChord NoteEvent)))) + ;; This works for single-note and multi-note tremolos! + (let* ((children (if (music-is-of-type? e 'sequential-music) + ;; \repeat tremolo n { ... } + (length (extract-named-music e '(EventChord + NoteEvent))) + ;; \repeat tremolo n c4 + 1)) + (times (ly:music-property music 'repeat-count)) + + ;; # of dots is equal to the 1 in bitwise representation (minus 1)! + (dots (1- (logcount (* times children)))) + ;; The remaining missing multiplicator to scale the notes by + ;; times * children + (mult (/ (* times children (ash 1 dots)) (1- (ash 2 dots)))) + (shift (- (ly:intlog2 (floor mult))))) + + ;; Adjust the time of the notes + (ly:music-compress music (ly:make-moment children 1)) + ;; Adjust the displayed note durations + (shift-duration-log music (- shift) (- dots)))))) (if (pair? es) - (set! (ly:music-property music 'elements) - (map unfold-repeats es))) + (set! (ly:music-property music 'elements) + (map unfold-repeats es))) (if (ly:music? e) - (set! (ly:music-property music 'element) - (unfold-repeats e))) + (set! (ly:music-property music 'element) + (unfold-repeats e))) music)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -465,24 +465,24 @@ respectively." "Make a @code{Music} expression that sets @var{gprop} to @var{val} in @var{grob}. Does a pop first, i.e., this is not an override." (make-music 'OverrideProperty - 'symbol grob - 'grob-property gprop - 'grob-value val - 'pop-first #t)) + 'symbol grob + 'grob-property gprop + 'grob-value val + 'pop-first #t)) (define-public (make-grob-property-override grob gprop val) "Make a @code{Music} expression that overrides @var{gprop} to @var{val} in @var{grob}." (make-music 'OverrideProperty - 'symbol grob - 'grob-property gprop - 'grob-value val)) + 'symbol grob + 'grob-property gprop + 'grob-value val)) (define-public (make-grob-property-revert grob gprop) "Revert the grob property @var{gprop} for @var{grob}." (make-music 'RevertProperty - 'symbol grob - 'grob-property gprop)) + 'symbol grob + 'grob-property gprop)) (define direction-polyphonic-grobs '(AccidentalSuggestion @@ -507,25 +507,25 @@ in @var{grob}." (make-sequential-music (append (map (lambda (x) (make-grob-property-set x 'direction - (if (odd? n) -1 1))) - direction-polyphonic-grobs) + (if (odd? n) -1 1))) + direction-polyphonic-grobs) (list (make-property-set 'graceSettings - ;; TODO: take this from voicedGraceSettings or similar. - '((Voice Stem font-size -3) - (Voice Flag font-size -3) - (Voice NoteHead font-size -3) - (Voice TabNoteHead font-size -4) - (Voice Dots font-size -3) - (Voice Stem length-fraction 0.8) - (Voice Stem no-stem-extend #t) - (Voice Beam beam-thickness 0.384) - (Voice Beam length-fraction 0.8) - (Voice Accidental font-size -4) - (Voice AccidentalCautionary font-size -4) - (Voice Script font-size -3) - (Voice Fingering font-size -8) - (Voice StringNumber font-size -8))) + ;; TODO: take this from voicedGraceSettings or similar. + '((Voice Stem font-size -3) + (Voice Flag font-size -3) + (Voice NoteHead font-size -3) + (Voice TabNoteHead font-size -4) + (Voice Dots font-size -3) + (Voice Stem length-fraction 0.8) + (Voice Stem no-stem-extend #t) + (Voice Beam beam-thickness 0.384) + (Voice Beam length-fraction 0.8) + (Voice Accidental font-size -4) + (Voice AccidentalCautionary font-size -4) + (Voice Script font-size -3) + (Voice Fingering font-size -8) + (Voice StringNumber font-size -8))) (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2)))))) @@ -534,25 +534,25 @@ in @var{grob}." (make-sequential-music (append (map (lambda (x) (make-grob-property-override x 'direction - (if (odd? n) -1 1))) - direction-polyphonic-grobs) + (if (odd? n) -1 1))) + direction-polyphonic-grobs) (list (make-property-set 'graceSettings - ;; TODO: take this from voicedGraceSettings or similar. - '((Voice Stem font-size -3) - (Voice Flag font-size -3) - (Voice NoteHead font-size -3) - (Voice TabNoteHead font-size -4) - (Voice Dots font-size -3) - (Voice Stem length-fraction 0.8) - (Voice Stem no-stem-extend #t) - (Voice Beam beam-thickness 0.384) - (Voice Beam length-fraction 0.8) - (Voice Accidental font-size -4) - (Voice AccidentalCautionary font-size -4) - (Voice Script font-size -3) - (Voice Fingering font-size -8) - (Voice StringNumber font-size -8))) + ;; TODO: take this from voicedGraceSettings or similar. + '((Voice Stem font-size -3) + (Voice Flag font-size -3) + (Voice NoteHead font-size -3) + (Voice TabNoteHead font-size -4) + (Voice Dots font-size -3) + (Voice Stem length-fraction 0.8) + (Voice Stem no-stem-extend #t) + (Voice Beam beam-thickness 0.384) + (Voice Beam length-fraction 0.8) + (Voice Accidental font-size -4) + (Voice AccidentalCautionary font-size -4) + (Voice Script font-size -3) + (Voice Fingering font-size -8) + (Voice StringNumber font-size -8))) (make-grob-property-override 'NoteColumn 'horizontal-shift (quotient n 2)) (make-grob-property-override 'MultiMeasureRest 'staff-position (if (odd? n) -4 4)))))) @@ -561,19 +561,19 @@ in @var{grob}." (make-sequential-music (append (map (lambda (x) (make-grob-property-revert x 'direction)) - direction-polyphonic-grobs) + direction-polyphonic-grobs) (list (make-property-unset 'graceSettings) - (make-grob-property-revert 'NoteColumn 'horizontal-shift) - (make-grob-property-revert 'MultiMeasureRest 'staff-position))))) + (make-grob-property-revert 'NoteColumn 'horizontal-shift) + (make-grob-property-revert 'MultiMeasureRest 'staff-position))))) (define-safe-public (context-spec-music m context #:optional id) "Add \\context CONTEXT = ID to M." (let ((cm (make-music 'ContextSpeccedMusic - 'element m - 'context-type context))) + 'element m + 'context-type context))) (if (string? id) - (set! (ly:music-property cm 'context-id) id)) + (set! (ly:music-property cm 'context-id) id)) cm)) (define-public (descend-to-context m context) @@ -584,82 +584,82 @@ in @var{grob}." (define-public (make-non-relative-music mus) (make-music 'UnrelativableMusic - 'element mus)) + 'element mus)) (define-public (make-apply-context func) (make-music 'ApplyContext - 'procedure func)) + 'procedure func)) (define-public (make-sequential-music elts) (make-music 'SequentialMusic - 'elements elts)) + 'elements elts)) (define-public (make-simultaneous-music elts) (make-music 'SimultaneousMusic - 'elements elts)) + 'elements elts)) (define-safe-public (make-event-chord elts) (make-music 'EventChord - 'elements elts)) + 'elements elts)) (define-public (make-skip-music dur) (make-music 'SkipMusic - 'duration dur)) + 'duration dur)) (define-public (make-grace-music music) (make-music 'GraceMusic - 'element music)) + 'element music)) ;;;;;;;;;;;;;;;; ;; mmrest (define-public (make-multi-measure-rest duration location) (make-music 'MultiMeasureRestMusic - 'origin location - 'duration duration)) + 'origin location + 'duration duration)) (define-public (make-property-set sym val) (make-music 'PropertySet - 'symbol sym - 'value val)) + 'symbol sym + 'value val)) (define-public (make-property-unset sym) (make-music 'PropertyUnset - 'symbol sym)) + 'symbol sym)) (define-safe-public (make-articulation name) (make-music 'ArticulationEvent - 'articulation-type name)) + 'articulation-type name)) (define-public (make-lyric-event string duration) (make-music 'LyricEvent - 'duration duration - 'text string)) + 'duration duration + 'text string)) (define-safe-public (make-span-event type span-dir) (make-music type - 'span-direction span-dir)) + 'span-direction span-dir)) (define-public (override-head-style heads style) "Override style for @var{heads} to @var{style}." (make-sequential-music - (if (pair? heads) - (map (lambda (h) + (if (pair? heads) + (map (lambda (h) (make-grob-property-override h 'style style)) - heads) - (list (make-grob-property-override heads 'style style))))) + heads) + (list (make-grob-property-override heads 'style style))))) (define-public (revert-head-style heads) "Revert style for @var{heads}." (make-sequential-music - (if (pair? heads) - (map (lambda (h) + (if (pair? heads) + (map (lambda (h) (make-grob-property-revert h 'style)) - heads) - (list (make-grob-property-revert heads 'style))))) + heads) + (list (make-grob-property-revert heads 'style))))) (define-public (style-note-heads heads style music) - "Set @var{style} for all @var{heads} in @var{music}. Works both + "Set @var{style} for all @var{heads} in @var{music}. Works both inside of and outside of chord construct." ;; are we inside a <...>? (if (eq? (ly:music-property music 'name) 'NoteEvent) @@ -670,17 +670,17 @@ inside of and outside of chord construct." music) ;; not in <...>, so use overrides (make-sequential-music - (list - (override-head-style heads style) - music - (revert-head-style heads))))) + (list + (override-head-style heads style) + music + (revert-head-style heads))))) - (define-public (set-mus-properties! m alist) +(define-public (set-mus-properties! m alist) "Set all of @var{alist} as properties of @var{m}." (if (pair? alist) (begin - (set! (ly:music-property m (caar alist)) (cdar alist)) - (set-mus-properties! m (cdr alist))))) + (set! (ly:music-property m (caar alist)) (cdar alist)) + (set-mus-properties! m (cdr alist))))) (define-public (music-separator? m) "Is @var{m} a separator?" @@ -689,7 +689,7 @@ inside of and outside of chord construct." ;;; expanding repeat chords (define-public (copy-repeat-chord original-chord repeat-chord duration - event-types) + event-types) "Copies all events in @var{event-types} (be sure to include @code{rhythmic-events}) from @var{original-chord} over to @var{repeat-chord} with their articulations filtered as well. Any @@ -701,47 +701,47 @@ duration is replaced with the specified @var{duration}." (define (keep-element? m) (any (lambda (t) (music-is-of-type? m t)) - event-types)) + event-types)) (define origin (ly:music-property repeat-chord 'origin #f)) (define (set-origin! l) (if origin - (for-each (lambda (m) (set! (ly:music-property m 'origin) origin)) l)) + (for-each (lambda (m) (set! (ly:music-property m 'origin) origin)) l)) l) (for-each (lambda (field) (for-each (lambda (e) - (for-each (lambda (x) - (set! event-types (delq x event-types))) - (ly:music-property e 'types))) - (ly:music-property repeat-chord field))) + (for-each (lambda (x) + (set! event-types (delq x event-types))) + (ly:music-property e 'types))) + (ly:music-property repeat-chord field))) '(elements articulations)) ;; now treat the elements (set! (ly:music-property repeat-chord 'elements) - (let ((elts - (set-origin! (ly:music-deep-copy - (filter keep-element? - (ly:music-property original-chord - 'elements)))))) - (for-each - (lambda (m) - (let ((arts (ly:music-property m 'articulations))) - (if (pair? arts) - (set! (ly:music-property m 'articulations) - (set-origin! (filter! keep-element? arts)))) - (if (ly:duration? (ly:music-property m 'duration)) - (set! (ly:music-property m 'duration) duration)))) - elts) - (append! elts (ly:music-property repeat-chord 'elements)))) + (let ((elts + (set-origin! (ly:music-deep-copy + (filter keep-element? + (ly:music-property original-chord + 'elements)))))) + (for-each + (lambda (m) + (let ((arts (ly:music-property m 'articulations))) + (if (pair? arts) + (set! (ly:music-property m 'articulations) + (set-origin! (filter! keep-element? arts)))) + (if (ly:duration? (ly:music-property m 'duration)) + (set! (ly:music-property m 'duration) duration)))) + elts) + (append! elts (ly:music-property repeat-chord 'elements)))) (let ((arts (filter keep-element? - (ly:music-property original-chord - 'articulations)))) + (ly:music-property original-chord + 'articulations)))) (if (pair? arts) - (set! (ly:music-property repeat-chord 'articulations) - (append! - (set-origin! (ly:music-deep-copy arts)) - (ly:music-property repeat-chord 'articulations)))))) + (set! (ly:music-property repeat-chord 'articulations) + (append! + (set-origin! (ly:music-deep-copy arts)) + (ly:music-property repeat-chord 'articulations)))))) (define-public (expand-repeat-chords! event-types music) @@ -750,24 +750,24 @@ having a duration in @code{duration}) with the notes from their respective predecessor chord." (let loop ((music music) (last-chord #f)) (if (music-is-of-type? music 'event-chord) - (let ((chord-repeat (ly:music-property music 'duration))) - (cond - ((not (ly:duration? chord-repeat)) - (if (any (lambda (m) (ly:duration? - (ly:music-property m 'duration))) - (ly:music-property music 'elements)) - music - last-chord)) - (last-chord - (set! (ly:music-property music 'duration) '()) - (copy-repeat-chord last-chord music chord-repeat event-types) - music) - (else - (ly:music-warning music (_ "Bad chord repetition")) - #f))) - (let ((elt (ly:music-property music 'element))) - (fold loop (if (ly:music? elt) (loop elt last-chord) last-chord) - (ly:music-property music 'elements))))) + (let ((chord-repeat (ly:music-property music 'duration))) + (cond + ((not (ly:duration? chord-repeat)) + (if (any (lambda (m) (ly:duration? + (ly:music-property m 'duration))) + (ly:music-property music 'elements)) + music + last-chord)) + (last-chord + (set! (ly:music-property music 'duration) '()) + (copy-repeat-chord last-chord music chord-repeat event-types) + music) + (else + (ly:music-warning music (_ "Bad chord repetition")) + #f))) + (let ((elt (ly:music-property music 'element))) + (fold loop (if (ly:music? elt) (loop elt last-chord) last-chord) + (ly:music-property music 'elements))))) music) ;;; splitting chords into voices. @@ -782,17 +782,17 @@ NUMBER is 0-base, i.e., Voice=1 (upstems) has number 0. (if (null? lst) '() (cons (context-spec-music - (make-sequential-music - (list (make-voice-props-set number) - (make-simultaneous-music (car lst)))) - 'Bottom (number->string (1+ number))) - (voicify-list (cdr lst) (1+ number))))) + (make-sequential-music + (list (make-voice-props-set number) + (make-simultaneous-music (car lst)))) + 'Bottom (number->string (1+ number))) + (voicify-list (cdr lst) (1+ number))))) (define (voicify-chord ch) "Split the parts of a chord into different Voices using separator" (let ((es (ly:music-property ch 'elements))) (set! (ly:music-property ch 'elements) - (voicify-list (split-list-by-separator es music-separator?) 0)) + (voicify-list (split-list-by-separator es music-separator?) 0)) ch)) (define-public (voicify-music m) @@ -800,15 +800,15 @@ NUMBER is 0-base, i.e., Voice=1 (upstems) has number 0. (if (not (ly:music? m)) (ly:error (_ "music expected: ~S") m)) (let ((es (ly:music-property m 'elements)) - (e (ly:music-property m 'element))) + (e (ly:music-property m 'element))) (if (pair? es) - (set! (ly:music-property m 'elements) (map voicify-music es))) + (set! (ly:music-property m 'elements) (map voicify-music es))) (if (ly:music? e) - (set! (ly:music-property m 'element) (voicify-music e))) + (set! (ly:music-property m 'element) (voicify-music e))) (if (and (equal? (ly:music-property m 'name) 'SimultaneousMusic) - (any music-separator? es)) - (set! m (context-spec-music (voicify-chord m) 'Staff))) + (any music-separator? es)) + (set! m (context-spec-music (voicify-chord m) 'Staff))) m)) (define-public (empty-music) @@ -829,7 +829,7 @@ NUMBER is 0-base, i.e., Voice=1 (upstems) has number 0. @code{\\applyoutput #(set-output-property 'Clef 'extra-offset '(0 . 1))}" (let ((meta (ly:grob-property grob 'meta))) (if (equal? (assoc-get 'name meta) grob-name) - (set! (ly:grob-property grob symbol) val)))) + (set! (ly:grob-property grob symbol) val)))) (define-public (skip->rest mus) @@ -837,8 +837,8 @@ NUMBER is 0-base, i.e., Voice=1 (upstems) has number 0. @code{SkipEvent}. Useful for extracting parts from crowded scores." (if (memq (ly:music-property mus 'name) '(SkipEvent SkipMusic)) - (make-music 'RestEvent 'duration (ly:music-property mus 'duration)) - mus)) + (make-music 'RestEvent 'duration (ly:music-property mus 'duration)) + mus)) (define-public (music-has-type music type) @@ -899,7 +899,7 @@ actually fully cloned." (define (vector-extend v x) "Make a new vector consisting of V, with X added to the end." (let* ((n (vector-length v)) - (nv (make-vector (+ n 1) '()))) + (nv (make-vector (+ n 1) '()))) (vector-move-left! v 0 n nv 0) (vector-set! nv n x) nv)) @@ -921,9 +921,9 @@ actually fully cloned." "Set @var{sym}=@var{val} for @var{grob} in @var{context-name}." (define (set-prop context) (let* ((where (ly:context-property-where-defined context 'graceSettings)) - (current (ly:context-property where 'graceSettings)) - (new-settings (append current - (list (list context-name grob sym val))))) + (current (ly:context-property where 'graceSettings)) + (new-settings (append current + (list (list context-name grob sym val))))) (ly:context-set-property! where 'graceSettings new-settings))) (context-spec-music (make-apply-context set-prop) 'Voice)) @@ -935,14 +935,14 @@ actually fully cloned." (eq? (caddr property) sym))) (define (delete-prop context) (let* ((where (ly:context-property-where-defined context 'graceSettings)) - (current (ly:context-property where 'graceSettings)) + (current (ly:context-property where 'graceSettings)) (prop-settings (filter - (lambda(x) (sym-grob-context? x sym grob context-name)) - current)) - (new-settings current)) + (lambda(x) (sym-grob-context? x sym grob context-name)) + current)) + (new-settings current)) (for-each (lambda(x) - (set! new-settings (delete x new-settings))) - prop-settings) + (set! new-settings (delete x new-settings))) + prop-settings) (ly:context-set-property! where 'graceSettings new-settings))) (context-spec-music (make-apply-context delete-prop) 'Voice)) @@ -953,11 +953,11 @@ actually fully cloned." `(define-music-function (parser location music) (ly:music?) ,@docstring (make-music 'GraceMusic - 'origin location - 'element (make-music 'SequentialMusic - 'elements (list (ly:music-deep-copy ,start) - music - (ly:music-deep-copy ,stop)))))) + 'origin location + 'element (make-music 'SequentialMusic + 'elements (list (ly:music-deep-copy ,start) + music + (ly:music-deep-copy ,stop)))))) (defmacro-public define-syntax-function (type args signature . body) "Helper macro for `ly:make-music-function'. @@ -982,23 +982,23 @@ predicates, to be used in case of a type error in arguments or result." (set! signature (map (lambda (pred) - (if (pair? pred) - `(cons ,(car pred) - ,(and (pair? (cdr pred)) (cadr pred))) - pred)) - (cons type signature))) + (if (pair? pred) + `(cons ,(car pred) + ,(and (pair? (cdr pred)) (cadr pred))) + pred)) + (cons type signature))) (if (and (pair? body) (pair? (car body)) (eqv? '_i (caar body))) ;; When the music function definition contains a i10n doc string, ;; (_i "doc string"), keep the literal string only (let ((docstring (cadar body)) - (body (cdr body))) - `(ly:make-music-function (list ,@signature) - (lambda ,args - ,docstring - ,@body))) + (body (cdr body))) + `(ly:make-music-function (list ,@signature) + (lambda ,args + ,docstring + ,@body))) `(ly:make-music-function (list ,@signature) - (lambda ,args - ,@body)))) + (lambda ,args + ,@body)))) (defmacro-public define-music-function rest "Defining macro returning music functions. @@ -1086,57 +1086,57 @@ set to the @code{location} parameter." (if (vector? (ly:music-property quote-music 'quoted-events)) (let* ((dir (ly:music-property quote-music 'quoted-voice-direction)) - (clef (ly:music-property quote-music 'quoted-music-clef #f)) - (main-voice (case dir ((1) 1) ((-1) 0) (else #f))) - (cue-voice (and main-voice (- 1 main-voice))) - (main-music (ly:music-property quote-music 'element)) - (return-value quote-music)) - - (if main-voice - (set! (ly:music-property quote-music 'element) - (make-sequential-music - (list - (make-voice-props-override main-voice) - main-music - (make-voice-props-revert))))) - - ;; if we have stem dirs, change both quoted and main music - ;; to have opposite stems. - - ;; cannot context-spec Quote-music, since context - ;; for the quotes is determined in the iterator. - - (make-sequential-music - (delq! #f - (list - (and clef (make-cue-clef-set clef)) - - ;; Need to establish CueVoice context even in #CENTER case - (context-spec-music - (if cue-voice - (make-voice-props-override cue-voice) - (make-music 'Music)) - 'CueVoice "cue") - quote-music - (and cue-voice - (context-spec-music - (make-voice-props-revert) 'CueVoice "cue")) - (and clef (make-cue-clef-unset)))))) + (clef (ly:music-property quote-music 'quoted-music-clef #f)) + (main-voice (case dir ((1) 1) ((-1) 0) (else #f))) + (cue-voice (and main-voice (- 1 main-voice))) + (main-music (ly:music-property quote-music 'element)) + (return-value quote-music)) + + (if main-voice + (set! (ly:music-property quote-music 'element) + (make-sequential-music + (list + (make-voice-props-override main-voice) + main-music + (make-voice-props-revert))))) + + ;; if we have stem dirs, change both quoted and main music + ;; to have opposite stems. + + ;; cannot context-spec Quote-music, since context + ;; for the quotes is determined in the iterator. + + (make-sequential-music + (delq! #f + (list + (and clef (make-cue-clef-set clef)) + + ;; Need to establish CueVoice context even in #CENTER case + (context-spec-music + (if cue-voice + (make-voice-props-override cue-voice) + (make-music 'Music)) + 'CueVoice "cue") + quote-music + (and cue-voice + (context-spec-music + (make-voice-props-revert) 'CueVoice "cue")) + (and clef (make-cue-clef-unset)))))) quote-music)) (define-public ((quote-substitute quote-tab) music) (let* ((quoted-name (ly:music-property music 'quoted-music-name)) - (quoted-vector (and (string? quoted-name) - (hash-ref quote-tab quoted-name #f)))) + (quoted-vector (and (string? quoted-name) + (hash-ref quote-tab quoted-name #f)))) (if (string? quoted-name) - (if (vector? quoted-vector) - (begin - (set! (ly:music-property music 'quoted-events) quoted-vector) - (set! (ly:music-property music 'iterator-ctor) - ly:quote-iterator::constructor)) - (ly:music-warning music (ly:format (_ "cannot find quoted music: `~S'") quoted-name)))) + (if (vector? quoted-vector) + (begin + (set! (ly:music-property music 'quoted-events) quoted-vector) + (set! (ly:music-property music 'iterator-ctor) + ly:quote-iterator::constructor)) + (ly:music-warning music (ly:format (_ "cannot find quoted music: `~S'") quoted-name)))) music)) @@ -1154,8 +1154,8 @@ set to the @code{location} parameter." (define found #f) (define (signal m) (if (and (ly:music? m) - (eq? (ly:music-property m 'error-found) #t)) - (set! found #t))) + (eq? (ly:music-property m 'error-found) #t)) + (set! found #t))) (for-each signal (ly:music-property music 'elements)) (signal (ly:music-property music 'element)) @@ -1166,27 +1166,27 @@ set to the @code{location} parameter." (define (precompute-music-length music) (set! (ly:music-property music 'length) - (ly:music-length music)) + (ly:music-length music)) music) (define-public (make-duration-of-length moment) - "Make duration of the given @code{moment} length." - (ly:make-duration 0 0 - (ly:moment-main-numerator moment) - (ly:moment-main-denominator moment))) + "Make duration of the given @code{moment} length." + (ly:make-duration 0 0 + (ly:moment-main-numerator moment) + (ly:moment-main-denominator moment))) (define (make-skipped moment bool) - "Depending on BOOL, set or unset skipTypesetting, + "Depending on BOOL, set or unset skipTypesetting, then make SkipMusic of the given MOMENT length, and then revert skipTypesetting." - (make-sequential-music - (list - (context-spec-music (make-property-set 'skipTypesetting bool) - 'Score) - (make-music 'SkipMusic 'duration - (make-duration-of-length moment)) - (context-spec-music (make-property-set 'skipTypesetting (not bool)) - 'Score)))) + (make-sequential-music + (list + (context-spec-music (make-property-set 'skipTypesetting bool) + 'Score) + (make-music 'SkipMusic 'duration + (make-duration-of-length moment)) + (context-spec-music (make-property-set 'skipTypesetting (not bool)) + 'Score)))) (define (skip-as-needed music parser) "Replace MUSIC by @@ -1204,9 +1204,9 @@ then revert skipTypesetting." ((show-last (ly:parser-lookup parser 'showLastLength)) (show-first (ly:parser-lookup parser 'showFirstLength)) (show-last-length (and (ly:music? show-last) - (ly:music-length show-last))) + (ly:music-length show-last))) (show-first-length (and (ly:music? show-first) - (ly:music-length show-first))) + (ly:music-length show-first))) (orig-length (ly:music-length music))) ;;FIXME: if using either showFirst- or showLastLength, @@ -1253,9 +1253,9 @@ then revert skipTypesetting." (define-public toplevel-music-functions (list (lambda (music parser) (expand-repeat-chords! - (cons 'rhythmic-event - (ly:parser-lookup parser '$chord-repeat-events)) - music)) + (cons 'rhythmic-event + (ly:parser-lookup parser '$chord-repeat-events)) + music)) (lambda (music parser) (voicify-music music)) (lambda (x parser) (music-map music-check-error x)) (lambda (x parser) (music-map precompute-music-length x)) @@ -1268,7 +1268,7 @@ then revert skipTypesetting." (lambda (x parser) (skip-as-needed x parser) - ))) + ))) ;;;;;;;;;; ;;; general purpose music functions @@ -1276,9 +1276,9 @@ then revert skipTypesetting." (define (shift-octave pitch octave-shift) (_i "Add @var{octave-shift} to the octave of @var{pitch}.") (ly:make-pitch - (+ (ly:pitch-octave pitch) octave-shift) - (ly:pitch-notename pitch) - (ly:pitch-alteration pitch))) + (+ (ly:pitch-octave pitch) octave-shift) + (ly:pitch-notename pitch) + (ly:pitch-alteration pitch))) ;;;;;;;;;;;;;;;;; @@ -1287,10 +1287,10 @@ then revert skipTypesetting." (define (apply-durations lyric-music durations) (define (apply-duration music) (if (and (not (equal? (ly:music-length music) ZERO-MOMENT)) - (ly:duration? (ly:music-property music 'duration))) - (begin - (set! (ly:music-property music 'duration) (car durations)) - (set! durations (cdr durations))))) + (ly:duration? (ly:music-property music 'duration))) + (begin + (set! (ly:music-property music 'duration) (car durations)) + (set! durations (cdr durations))))) (music-map apply-duration lyric-music)) @@ -1312,16 +1312,16 @@ can be omitted when the same note occurs again. Returns @code{#f} or the reason for the invalidation, a symbol." (let* ((def (if (pair? alteration-def) - (car alteration-def) - alteration-def))) + (car alteration-def) + alteration-def))) (and (symbol? def) def))) (define (extract-alteration alteration-def) (cond ((number? alteration-def) - alteration-def) - ((pair? alteration-def) - (car alteration-def)) - (else 0))) + alteration-def) + ((pair? alteration-def) + (car alteration-def)) + (else 0))) (define (check-pitch-against-signature context pitch barnum laziness octaveness) "Checks the need for an accidental and a @q{restore} accidental against @@ -1332,50 +1332,50 @@ we cancel accidentals up to three measures after they first appear. @var{octaveness} is either @code{'same-octave} or @code{'any-octave} and specifies whether accidentals should be canceled in different octaves." (let* ((ignore-octave (cond ((equal? octaveness 'any-octave) #t) - ((equal? octaveness 'same-octave) #f) - (else - (ly:warning (_ "Unknown octaveness type: ~S ") octaveness) - (ly:warning (_ "Defaulting to 'any-octave.")) - #t))) - (key-sig (ly:context-property context 'keySignature)) - (local-key-sig (ly:context-property context 'localKeySignature)) - (notename (ly:pitch-notename pitch)) - (octave (ly:pitch-octave pitch)) - (pitch-handle (cons octave notename)) - (need-restore #f) - (need-accidental #f) - (previous-alteration #f) - (from-other-octaves #f) - (from-same-octave (assoc-get pitch-handle local-key-sig)) - (from-key-sig (or (assoc-get notename local-key-sig) - - ;; If no key signature match is found from localKeySignature, we may have a custom - ;; type with octave-specific entries of the form ((octave . pitch) alteration) - ;; instead of (pitch . alteration). Since this type cannot coexist with entries in - ;; localKeySignature, try extracting from keySignature instead. - (assoc-get pitch-handle key-sig)))) + ((equal? octaveness 'same-octave) #f) + (else + (ly:warning (_ "Unknown octaveness type: ~S ") octaveness) + (ly:warning (_ "Defaulting to 'any-octave.")) + #t))) + (key-sig (ly:context-property context 'keySignature)) + (local-key-sig (ly:context-property context 'localKeySignature)) + (notename (ly:pitch-notename pitch)) + (octave (ly:pitch-octave pitch)) + (pitch-handle (cons octave notename)) + (need-restore #f) + (need-accidental #f) + (previous-alteration #f) + (from-other-octaves #f) + (from-same-octave (assoc-get pitch-handle local-key-sig)) + (from-key-sig (or (assoc-get notename local-key-sig) + + ;; If no key signature match is found from localKeySignature, we may have a custom + ;; type with octave-specific entries of the form ((octave . pitch) alteration) + ;; instead of (pitch . alteration). Since this type cannot coexist with entries in + ;; localKeySignature, try extracting from keySignature instead. + (assoc-get pitch-handle key-sig)))) ;; loop through localKeySignature to search for a notename match from other octaves (let loop ((l local-key-sig)) (if (pair? l) - (let ((entry (car l))) - (if (and (pair? (car entry)) - (= (cdar entry) notename)) - (set! from-other-octaves (cdr entry)) - (loop (cdr l)))))) + (let ((entry (car l))) + (if (and (pair? (car entry)) + (= (cdar entry) notename)) + (set! from-other-octaves (cdr entry)) + (loop (cdr l)))))) ;; find previous alteration-def for comparison with pitch (cond ;; from same octave? ((and (not ignore-octave) - from-same-octave - (recent-enough? barnum from-same-octave laziness)) + from-same-octave + (recent-enough? barnum from-same-octave laziness)) (set! previous-alteration from-same-octave)) ;; from any octave? ((and ignore-octave - from-other-octaves - (recent-enough? barnum from-other-octaves laziness)) + from-other-octaves + (recent-enough? barnum from-other-octaves laziness)) (set! previous-alteration from-other-octaves)) ;; not recent enough, extract from key signature/local key signature @@ -1383,18 +1383,18 @@ specifies whether accidentals should be canceled in different octaves." (set! previous-alteration from-key-sig))) (if (accidental-invalid? previous-alteration) - (set! need-accidental #t) + (set! need-accidental #t) - (let* ((prev-alt (extract-alteration previous-alteration)) - (this-alt (ly:pitch-alteration pitch))) + (let* ((prev-alt (extract-alteration previous-alteration)) + (this-alt (ly:pitch-alteration pitch))) - (if (not (= this-alt prev-alt)) - (begin - (set! need-accidental #t) - (if (and (not (= this-alt 0)) - (and (< (abs this-alt) (abs prev-alt)) - (> (* prev-alt this-alt) 0))) - (set! need-restore #t)))))) + (if (not (= this-alt prev-alt)) + (begin + (set! need-accidental #t) + (if (and (not (= this-alt 0)) + (and (< (abs this-alt) (abs prev-alt)) + (> (* prev-alt this-alt) 0))) + (set! need-restore #t)))))) (cons need-restore need-accidental))) @@ -1455,8 +1455,8 @@ See @code{key-entry-notename} for details." For convenience, returns @code{0} if entry is @code{#f}." (if entry (if (number? (cdr entry)) - (cdr entry) - (cadr entry)) + (cdr entry) + (cadr entry)) 0)) (define-public (find-pitch-entry keysig pitch accept-global accept-local) @@ -1466,17 +1466,17 @@ For convenience, returns @code{0} if entry is @code{#f}." If no matching entry is found, @var{#f} is returned." (and (pair? keysig) (let* ((entry (car keysig)) - (entryoct (key-entry-octave entry)) - (entrynn (key-entry-notename entry)) - (nn (ly:pitch-notename pitch))) - (if (and (equal? nn entrynn) - (or (not entryoct) - (= entryoct (ly:pitch-octave pitch))) - (if (key-entry-bar-number entry) - accept-local - accept-global)) - entry - (find-pitch-entry (cdr keysig) pitch accept-global accept-local))))) + (entryoct (key-entry-octave entry)) + (entrynn (key-entry-notename entry)) + (nn (ly:pitch-notename pitch))) + (if (and (equal? nn entrynn) + (or (not entryoct) + (= entryoct (ly:pitch-octave pitch))) + (if (key-entry-bar-number entry) + accept-local + accept-global)) + entry + (find-pitch-entry (cdr keysig) pitch accept-global accept-local))))) (define-public (neo-modern-accidental-rule context pitch barnum measurepos) "An accidental rule that typesets an accidental if it differs from the @@ -1484,39 +1484,39 @@ key signature @emph{and} does not directly follow a note on the same staff line. This rule should not be used alone because it does neither look at bar lines nor different accidentals at the same note name." (let* ((keysig (ly:context-property context 'localKeySignature)) - (entry (find-pitch-entry keysig pitch #t #t))) + (entry (find-pitch-entry keysig pitch #t #t))) (if (not entry) - (cons #f #f) - (let* ((global-entry (find-pitch-entry keysig pitch #t #f)) - (key-acc (key-entry-alteration global-entry)) - (acc (ly:pitch-alteration pitch)) - (entrymp (key-entry-measure-position entry)) - (entrybn (key-entry-bar-number entry))) - (cons #f (not (or (equal? acc key-acc) - (and (equal? entrybn barnum) (equal? entrymp measurepos))))))))) + (cons #f #f) + (let* ((global-entry (find-pitch-entry keysig pitch #t #f)) + (key-acc (key-entry-alteration global-entry)) + (acc (ly:pitch-alteration pitch)) + (entrymp (key-entry-measure-position entry)) + (entrybn (key-entry-bar-number entry))) + (cons #f (not (or (equal? acc key-acc) + (and (equal? entrybn barnum) (equal? entrymp measurepos))))))))) (define-public (teaching-accidental-rule context pitch barnum measurepos) "An accidental rule that typesets a cautionary accidental if it is included in the key signature @emph{and} does not directly follow a note on the same staff line." (let* ((keysig (ly:context-property context 'localKeySignature)) - (entry (find-pitch-entry keysig pitch #t #t))) + (entry (find-pitch-entry keysig pitch #t #t))) (if (not entry) - (cons #f #f) - (let* ((entrymp (key-entry-measure-position entry)) - (entrybn (key-entry-bar-number entry))) - (cons #f (not (and (equal? entrybn barnum) (equal? entrymp measurepos)))))))) + (cons #f #f) + (let* ((entrymp (key-entry-measure-position entry)) + (entrybn (key-entry-bar-number entry))) + (cons #f (not (and (equal? entrybn barnum) (equal? entrymp measurepos)))))))) (define-public (set-accidentals-properties extra-natural - auto-accs auto-cauts - context) + auto-accs auto-cauts + context) (context-spec-music (make-sequential-music (append (if (boolean? extra-natural) - (list (make-property-set 'extraNatural extra-natural)) - '()) - (list (make-property-set 'autoAccidentals auto-accs) - (make-property-set 'autoCautionaries auto-cauts)))) + (list (make-property-set 'extraNatural extra-natural)) + '()) + (list (make-property-set 'autoAccidentals auto-accs) + (make-property-set 'autoCautionaries auto-cauts)))) context)) (define-public (set-accidental-style style . rest) @@ -1525,163 +1525,163 @@ argument, e.g. @code{'Staff} or @code{'Voice}. The context defaults to @code{Staff}, except for piano styles, which use @code{GrandStaff} as a context." (let ((context (if (pair? rest) - (car rest) 'Staff)) - (pcontext (if (pair? rest) - (car rest) 'GrandStaff))) + (car rest) 'Staff)) + (pcontext (if (pair? rest) + (car rest) 'GrandStaff))) (cond - ;; accidentals as they were common in the 18th century. - ((equal? style 'default) - (set-accidentals-properties #t - `(Staff ,(make-accidental-rule 'same-octave 0)) - '() - context)) - ;; accidentals from one voice do NOT get canceled in other voices - ((equal? style 'voice) - (set-accidentals-properties #t - `(Voice ,(make-accidental-rule 'same-octave 0)) - '() - context)) - ;; accidentals as suggested by Kurt Stone, Music Notation in the 20th century. - ;; This includes all the default accidentals, but accidentals also needs canceling - ;; in other octaves and in the next measure. - ((equal? style 'modern) - (set-accidentals-properties #f - `(Staff ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1)) - '() - context)) - ;; the accidentals that Stone adds to the old standard as cautionaries - ((equal? style 'modern-cautionary) - (set-accidentals-properties #f - `(Staff ,(make-accidental-rule 'same-octave 0)) - `(Staff ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1)) - context)) - ;; same as modern, but accidentals different from the key signature are always - ;; typeset - unless they directly follow a note of the same pitch. - ((equal? style 'neo-modern) - (set-accidentals-properties #f - `(Staff ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - ,neo-modern-accidental-rule) - '() - context)) - ((equal? style 'neo-modern-cautionary) - (set-accidentals-properties #f - `(Staff ,(make-accidental-rule 'same-octave 0)) - `(Staff ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - ,neo-modern-accidental-rule) - context)) - ((equal? style 'neo-modern-voice) - (set-accidentals-properties #f - `(Voice ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - ,neo-modern-accidental-rule - Staff ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - ,neo-modern-accidental-rule) - '() - context)) - ((equal? style 'neo-modern-voice-cautionary) - (set-accidentals-properties #f - `(Voice ,(make-accidental-rule 'same-octave 0)) - `(Voice ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - ,neo-modern-accidental-rule - Staff ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - ,neo-modern-accidental-rule) - context)) - ;; Accidentals as they were common in dodecaphonic music with no tonality. - ;; Each note gets one accidental. - ((equal? style 'dodecaphonic) - (set-accidentals-properties #f - `(Staff ,(lambda (c p bn mp) '(#f . #t))) - '() - context)) - ;; Multivoice accidentals to be read both by musicians playing one voice - ;; and musicians playing all voices. - ;; Accidentals are typeset for each voice, but they ARE canceled across voices. - ((equal? style 'modern-voice) - (set-accidentals-properties #f - `(Voice ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - Staff ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1)) - '() - context)) - ;; same as modernVoiceAccidental eccept that all special accidentals are typeset - ;; as cautionaries - ((equal? style 'modern-voice-cautionary) - (set-accidentals-properties #f - `(Voice ,(make-accidental-rule 'same-octave 0)) - `(Voice ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - Staff ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1)) - context)) - ;; stone's suggestions for accidentals on grand staff. - ;; Accidentals are canceled across the staves in the same grand staff as well - ((equal? style 'piano) - (set-accidentals-properties #f - `(Staff ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - GrandStaff - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1)) - '() - pcontext)) - ((equal? style 'piano-cautionary) - (set-accidentals-properties #f - `(Staff ,(make-accidental-rule 'same-octave 0)) - `(Staff ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - GrandStaff - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1)) - pcontext)) - - ;; same as modern, but cautionary accidentals are printed for all sharp or flat - ;; tones specified by the key signature. - ((equal? style 'teaching) - (set-accidentals-properties #f - `(Staff ,(make-accidental-rule 'same-octave 0)) - `(Staff ,(make-accidental-rule 'same-octave 1) - ,teaching-accidental-rule) - context)) - - ;; do not set localKeySignature when a note alterated differently from - ;; localKeySignature is found. - ;; Causes accidentals to be printed at every note instead of - ;; remembered for the duration of a measure. - ;; accidentals not being remembered, causing accidentals always to - ;; be typeset relative to the time signature - ((equal? style 'forget) - (set-accidentals-properties '() - `(Staff ,(make-accidental-rule 'same-octave -1)) - '() - context)) - ;; Do not reset the key at the start of a measure. Accidentals will be - ;; printed only once and are in effect until overridden, possibly many - ;; measures later. - ((equal? style 'no-reset) - (set-accidentals-properties '() - `(Staff ,(make-accidental-rule 'same-octave #t)) - '() - context)) - (else - (ly:warning (_ "unknown accidental style: ~S") style) - (make-sequential-music '()))))) + ;; accidentals as they were common in the 18th century. + ((equal? style 'default) + (set-accidentals-properties #t + `(Staff ,(make-accidental-rule 'same-octave 0)) + '() + context)) + ;; accidentals from one voice do NOT get canceled in other voices + ((equal? style 'voice) + (set-accidentals-properties #t + `(Voice ,(make-accidental-rule 'same-octave 0)) + '() + context)) + ;; accidentals as suggested by Kurt Stone, Music Notation in the 20th century. + ;; This includes all the default accidentals, but accidentals also needs canceling + ;; in other octaves and in the next measure. + ((equal? style 'modern) + (set-accidentals-properties #f + `(Staff ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1)) + '() + context)) + ;; the accidentals that Stone adds to the old standard as cautionaries + ((equal? style 'modern-cautionary) + (set-accidentals-properties #f + `(Staff ,(make-accidental-rule 'same-octave 0)) + `(Staff ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1)) + context)) + ;; same as modern, but accidentals different from the key signature are always + ;; typeset - unless they directly follow a note of the same pitch. + ((equal? style 'neo-modern) + (set-accidentals-properties #f + `(Staff ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + ,neo-modern-accidental-rule) + '() + context)) + ((equal? style 'neo-modern-cautionary) + (set-accidentals-properties #f + `(Staff ,(make-accidental-rule 'same-octave 0)) + `(Staff ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + ,neo-modern-accidental-rule) + context)) + ((equal? style 'neo-modern-voice) + (set-accidentals-properties #f + `(Voice ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + ,neo-modern-accidental-rule + Staff ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + ,neo-modern-accidental-rule) + '() + context)) + ((equal? style 'neo-modern-voice-cautionary) + (set-accidentals-properties #f + `(Voice ,(make-accidental-rule 'same-octave 0)) + `(Voice ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + ,neo-modern-accidental-rule + Staff ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + ,neo-modern-accidental-rule) + context)) + ;; Accidentals as they were common in dodecaphonic music with no tonality. + ;; Each note gets one accidental. + ((equal? style 'dodecaphonic) + (set-accidentals-properties #f + `(Staff ,(lambda (c p bn mp) '(#f . #t))) + '() + context)) + ;; Multivoice accidentals to be read both by musicians playing one voice + ;; and musicians playing all voices. + ;; Accidentals are typeset for each voice, but they ARE canceled across voices. + ((equal? style 'modern-voice) + (set-accidentals-properties #f + `(Voice ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + Staff ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1)) + '() + context)) + ;; same as modernVoiceAccidental eccept that all special accidentals are typeset + ;; as cautionaries + ((equal? style 'modern-voice-cautionary) + (set-accidentals-properties #f + `(Voice ,(make-accidental-rule 'same-octave 0)) + `(Voice ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + Staff ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1)) + context)) + ;; stone's suggestions for accidentals on grand staff. + ;; Accidentals are canceled across the staves in the same grand staff as well + ((equal? style 'piano) + (set-accidentals-properties #f + `(Staff ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + GrandStaff + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1)) + '() + pcontext)) + ((equal? style 'piano-cautionary) + (set-accidentals-properties #f + `(Staff ,(make-accidental-rule 'same-octave 0)) + `(Staff ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + GrandStaff + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1)) + pcontext)) + + ;; same as modern, but cautionary accidentals are printed for all sharp or flat + ;; tones specified by the key signature. + ((equal? style 'teaching) + (set-accidentals-properties #f + `(Staff ,(make-accidental-rule 'same-octave 0)) + `(Staff ,(make-accidental-rule 'same-octave 1) + ,teaching-accidental-rule) + context)) + + ;; do not set localKeySignature when a note alterated differently from + ;; localKeySignature is found. + ;; Causes accidentals to be printed at every note instead of + ;; remembered for the duration of a measure. + ;; accidentals not being remembered, causing accidentals always to + ;; be typeset relative to the time signature + ((equal? style 'forget) + (set-accidentals-properties '() + `(Staff ,(make-accidental-rule 'same-octave -1)) + '() + context)) + ;; Do not reset the key at the start of a measure. Accidentals will be + ;; printed only once and are in effect until overridden, possibly many + ;; measures later. + ((equal? style 'no-reset) + (set-accidentals-properties '() + `(Staff ,(make-accidental-rule 'same-octave #t)) + '() + context)) + (else + (ly:warning (_ "unknown accidental style: ~S") style) + (make-sequential-music '()))))) (define-public (invalidate-alterations context) "Invalidate alterations in @var{context}. @@ -1695,31 +1695,31 @@ to force a repetition of accidentals. Entries that conform with the current key signature are not invalidated." (let* ((keysig (ly:context-property context 'keySignature))) (set! (ly:context-property context 'localKeySignature) - (map-in-order - (lambda (entry) - (let* ((localalt (key-entry-alteration entry))) - (if (or (accidental-invalid? localalt) - (not (key-entry-bar-number entry)) - (= localalt - (key-entry-alteration - (find-pitch-entry - keysig - (ly:make-pitch (key-entry-octave entry) - (key-entry-notename entry) - 0) - #t #t)))) - entry - (cons (car entry) (cons 'clef (cddr entry)))))) - (ly:context-property context 'localKeySignature))))) + (map-in-order + (lambda (entry) + (let* ((localalt (key-entry-alteration entry))) + (if (or (accidental-invalid? localalt) + (not (key-entry-bar-number entry)) + (= localalt + (key-entry-alteration + (find-pitch-entry + keysig + (ly:make-pitch (key-entry-octave entry) + (key-entry-notename entry) + 0) + #t #t)))) + entry + (cons (car entry) (cons 'clef (cddr entry)))))) + (ly:context-property context 'localKeySignature))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-public (skip-of-length mus) "Create a skip of exactly the same length as @var{mus}." (let* ((skip - (make-music - 'SkipEvent - 'duration (ly:make-duration 0 0)))) + (make-music + 'SkipEvent + 'duration (ly:make-duration 0 0)))) (make-event-chord (list (ly:music-compress skip (ly:music-length mus)))))) @@ -1727,29 +1727,29 @@ Entries that conform with the current key signature are not invalidated." "Create a multi-measure rest of exactly the same length as @var{mus}." (let* ((skip - (make-multi-measure-rest - (ly:make-duration 0 0) '()))) + (make-multi-measure-rest + (ly:make-duration 0 0) '()))) (ly:music-compress skip (ly:music-length mus)) skip)) (define-public (pitch-of-note event-chord) (let ((evs (filter (lambda (x) - (music-has-type x 'note-event)) - (ly:music-property event-chord 'elements)))) + (music-has-type x 'note-event)) + (ly:music-property event-chord 'elements)))) (and (pair? evs) - (ly:music-property (car evs) 'pitch)))) + (ly:music-property (car evs) 'pitch)))) (define-public (duration-of-note event-chord) (cond ((pair? event-chord) (or (duration-of-note (car event-chord)) - (duration-of-note (cdr event-chord)))) + (duration-of-note (cdr event-chord)))) ((ly:music? event-chord) (let ((dur (ly:music-property event-chord 'duration))) (if (ly:duration? dur) - dur - (duration-of-note (ly:music-property event-chord 'elements))))) + dur + (duration-of-note (ly:music-property event-chord 'elements))))) (else #f))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1759,30 +1759,30 @@ Entries that conform with the current key signature are not invalidated." and only recurse if this returns @code{#f}." (let loop ((music music)) (or (map? music) - (let ((elt (ly:music-property music 'element)) - (elts (ly:music-property music 'elements)) - (arts (ly:music-property music 'articulations))) - (if (ly:music? elt) - (set! (ly:music-property music 'element) - (loop elt))) - (if (pair? elts) - (set! (ly:music-property music 'elements) - (map loop elts))) - (if (pair? arts) - (set! (ly:music-property music 'articulations) - (map loop arts))) - music)))) + (let ((elt (ly:music-property music 'element)) + (elts (ly:music-property music 'elements)) + (arts (ly:music-property music 'articulations))) + (if (ly:music? elt) + (set! (ly:music-property music 'element) + (loop elt))) + (if (pair? elts) + (set! (ly:music-property music 'elements) + (map loop elts))) + (if (pair? arts) + (set! (ly:music-property music 'articulations) + (map loop arts))) + music)))) (define-public (for-some-music stop? music) "Walk through @var{music}, process all elements calling @var{stop?} and only recurse if this returns @code{#f}." (let loop ((music music)) (if (not (stop? music)) - (let ((elt (ly:music-property music 'element))) - (if (ly:music? elt) - (loop elt)) - (for-each loop (ly:music-property music 'elements)) - (for-each loop (ly:music-property music 'articulations)))))) + (let ((elt (ly:music-property music 'element))) + (if (ly:music? elt) + (loop elt)) + (for-each loop (ly:music-property music 'elements)) + (for-each loop (ly:music-property music 'articulations)))))) (define-public (fold-some-music pred? proc init music) "This works recursively on music like @code{fold} does on a list, @@ -1794,15 +1794,15 @@ and no recursion happens. The top @var{music} is processed using @var{init} for @samp{previous}." (let loop ((music music) (previous init)) (if (pred? music) - (proc music previous) - (fold loop - (fold loop - (let ((elt (ly:music-property music 'element))) - (if (null? elt) - previous - (loop elt previous))) - (ly:music-property music 'elements)) - (ly:music-property music 'articulations))))) + (proc music previous) + (fold loop + (fold loop + (let ((elt (ly:music-property music 'element))) + (if (null? elt) + previous + (loop elt previous))) + (ly:music-property music 'elements)) + (ly:music-property music 'articulations))))) (define-public (extract-music music pred?) "Return a flat list of all music matching @var{pred?} inside of @@ -1827,7 +1827,7 @@ recursing into matches themselves." music (if (cheap-list? type) (lambda (m) - (any (lambda (t) (music-is-of-type? m t)) type)) + (any (lambda (t) (music-is-of-type? m t)) type)) (lambda (m) (music-is-of-type? m type))))) (define*-public (event-chord-wrap! music #:optional parser) @@ -1839,31 +1839,31 @@ yourself." (map-some-music (lambda (m) (cond ((music-is-of-type? m 'event-chord) - (if (pair? (ly:music-property m 'articulations)) - (begin - (set! (ly:music-property m 'elements) - (append (ly:music-property m 'elements) - (ly:music-property m 'articulations))) - (set! (ly:music-property m 'articulations) '()))) - m) - ((music-is-of-type? m 'rhythmic-event) - (let ((arts (ly:music-property m 'articulations))) - (if (pair? arts) - (set! (ly:music-property m 'articulations) '())) - (make-event-chord (cons m arts)))) - (else #f))) + (if (pair? (ly:music-property m 'articulations)) + (begin + (set! (ly:music-property m 'elements) + (append (ly:music-property m 'elements) + (ly:music-property m 'articulations))) + (set! (ly:music-property m 'articulations) '()))) + m) + ((music-is-of-type? m 'rhythmic-event) + (let ((arts (ly:music-property m 'articulations))) + (if (pair? arts) + (set! (ly:music-property m 'articulations) '())) + (make-event-chord (cons m arts)))) + (else #f))) (if parser (expand-repeat-chords! - (cons 'rhythmic-event - (ly:parser-lookup parser '$chord-repeat-events)) - music) + (cons 'rhythmic-event + (ly:parser-lookup parser '$chord-repeat-events)) + music) music))) (define-public (event-chord-notes event-chord) "Return a list of all notes from @var{event-chord}." (filter - (lambda (m) (eq? 'NoteEvent (ly:music-property m 'name))) - (ly:music-property event-chord 'elements))) + (lambda (m) (eq? 'NoteEvent (ly:music-property m 'name))) + (ly:music-property event-chord 'elements))) (define-public (event-chord-pitches event-chord) "Return a list of all pitches from @var{event-chord}." @@ -1910,7 +1910,7 @@ base onto the following musical context." (define (close-enough? x y) "Values are close enough to ignore the difference" - (< (abs (- x y)) 0.0001)) + (< (abs (- x y)) 0.0001)) (define (extent-combine extents) "Combine a list of extents" @@ -1923,34 +1923,34 @@ base onto the following musical context." ;; The root is always connectable to itself (or (eq? root stem) (and - ;; Horizontal positions of the stems must be almost the same - (close-enough? (car (ly:grob-extent root ref X)) - (car (ly:grob-extent stem ref X))) - ;; The stem must be in the direction away from the root's notehead - (positive? (* (ly:grob-property root 'direction) + ;; Horizontal positions of the stems must be almost the same + (close-enough? (car (ly:grob-extent root ref X)) + (car (ly:grob-extent stem ref X))) + ;; The stem must be in the direction away from the root's notehead + (positive? (* (ly:grob-property root 'direction) (- (car (ly:grob-extent stem ref Y)) - (car (ly:grob-extent root ref Y)))))))) + (car (ly:grob-extent root ref Y)))))))) (define (stem-span-stencil span) "Connect stems if we have at least one stem connectable to the root" (let* ((system (ly:grob-system span)) - (root (ly:grob-parent span X)) - (stems (filter (stem-connectable? system root) - (ly:grob-object span 'stems)))) - (if (<= 2 (length stems)) - (let* ((yextents (map (lambda (st) - (ly:grob-extent st system Y)) stems)) - (yextent (extent-combine yextents)) - (layout (ly:grob-layout root)) - (blot (ly:output-def-lookup layout 'blot-diameter))) - ;; Hide spanned stems - (map (lambda (st) - (set! (ly:grob-property st 'stencil) #f)) - stems) - ;; Draw a nice looking stem with rounded corners - (ly:round-filled-box (ly:grob-extent root root X) yextent blot)) - ;; Nothing to connect, don't draw the span - #f))) + (root (ly:grob-parent span X)) + (stems (filter (stem-connectable? system root) + (ly:grob-object span 'stems)))) + (if (<= 2 (length stems)) + (let* ((yextents (map (lambda (st) + (ly:grob-extent st system Y)) stems)) + (yextent (extent-combine yextents)) + (layout (ly:grob-layout root)) + (blot (ly:output-def-lookup layout 'blot-diameter))) + ;; Hide spanned stems + (map (lambda (st) + (set! (ly:grob-property st 'stencil) #f)) + stems) + ;; Draw a nice looking stem with rounded corners + (ly:round-filled-box (ly:grob-extent root root X) yextent blot)) + ;; Nothing to connect, don't draw the span + #f))) (define ((make-stem-span! stems trans) root) "Create a stem span as a child of the cross-staff stem (the root)" @@ -1964,7 +1964,7 @@ base onto the following musical context." (define-public (cross-staff-connect stem) "Set cross-staff property of the stem to this function to connect it to other stems automatically" - #t) + #t) (define (stem-is-root? stem) "Check if automatic connecting of the stem was requested. Stems connected @@ -1977,21 +1977,21 @@ other stems just because of that." ;; Cannot do extensive checks here, just make sure there are at least ;; two stems at this musical moment (if (<= 2 (length stems)) - (let ((roots (filter stem-is-root? stems))) - (map (make-stem-span! stems trans) roots)))) + (let ((roots (filter stem-is-root? stems))) + (map (make-stem-span! stems trans) roots)))) (define-public (Span_stem_engraver ctx) "Connect cross-staff stems to the stems above in the system" (let ((stems '())) (make-engraver - ;; Record all stems for the given moment - (acknowledgers - ((stem-interface trans grob source) - (set! stems (cons grob stems)))) - ;; Process stems and reset the stem list to empty - ((process-acknowledged trans) - (make-stem-spans! ctx stems trans) - (set! stems '()))))) + ;; Record all stems for the given moment + (acknowledgers + ((stem-interface trans grob source) + (set! stems (cons grob stems)))) + ;; Process stems and reset the stem list to empty + ((process-acknowledged trans) + (make-stem-spans! ctx stems trans) + (set! stems '()))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; The following is used by the alterBroken function. @@ -2002,16 +2002,16 @@ of list @var{arg}." (let* ((orig (ly:grob-original grob)) (siblings (ly:spanner-broken-into orig))) - (define (helper sibs arg) - (if (null? arg) - arg - (if (eq? (car sibs) grob) - (car arg) - (helper (cdr sibs) (cdr arg))))) + (define (helper sibs arg) + (if (null? arg) + arg + (if (eq? (car sibs) grob) + (car arg) + (helper (cdr sibs) (cdr arg))))) - (if (>= (length siblings) 2) - (helper siblings arg) - (car arg)))) + (if (>= (length siblings) 2) + (helper siblings arg) + (car arg)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; measure counter @@ -2030,45 +2030,45 @@ Broken measures are numbered in parentheses." ;; a system in the event that a MeasureCounter spanner is broken (all-cols (ly:grob-array->list (ly:grob-object refp 'columns))) (all-cols - (filter - (lambda (col) (eq? #t (ly:grob-property col 'non-musical))) - all-cols)) + (filter + (lambda (col) (eq? #t (ly:grob-property col 'non-musical))) + all-cols)) (left-bound - (if (or (null? siblings) ; spanner is unbroken - (eq? grob (car siblings))) ; or the first piece - (car bounds) - (car all-cols))) + (if (or (null? siblings) ; spanner is unbroken + (eq? grob (car siblings))) ; or the first piece + (car bounds) + (car all-cols))) (right-bound - (if (or (null? siblings) - (eq? grob (car (reverse siblings)))) - (car (reverse bounds)) - (car (reverse all-cols)))) + (if (or (null? siblings) + (eq? grob (car (reverse siblings)))) + (car (reverse bounds)) + (car (reverse all-cols)))) (elts-L (ly:grob-array->list (ly:grob-object left-bound 'elements))) (elts-R (ly:grob-array->list (ly:grob-object right-bound 'elements))) (break-alignment-L - (filter - (lambda (elt) (grob::has-interface elt 'break-alignment-interface)) - elts-L)) + (filter + (lambda (elt) (grob::has-interface elt 'break-alignment-interface)) + elts-L)) (break-alignment-R - (filter - (lambda (elt) (grob::has-interface elt 'break-alignment-interface)) - elts-R)) + (filter + (lambda (elt) (grob::has-interface elt 'break-alignment-interface)) + elts-R)) (break-alignment-L-ext (ly:grob-extent (car break-alignment-L) refp X)) (break-alignment-R-ext (ly:grob-extent (car break-alignment-R) refp X)) (num (markup (number->string (ly:grob-property grob 'count-from)))) (num - (if (or (null? siblings) - (eq? grob (car siblings))) - num - (make-parenthesize-markup num))) + (if (or (null? siblings) + (eq? grob (car siblings))) + num + (make-parenthesize-markup num))) (num (grob-interpret-markup grob num)) (num (ly:stencil-aligned-to num X (ly:grob-property grob 'self-alignment-X))) (num - (ly:stencil-translate-axis - num - (+ (interval-length break-alignment-L-ext) - (* 0.5 - (- (car break-alignment-R-ext) - (cdr break-alignment-L-ext)))) - X))) + (ly:stencil-translate-axis + num + (+ (interval-length break-alignment-L-ext) + (* 0.5 + (- (car break-alignment-R-ext) + (cdr break-alignment-L-ext)))) + X))) num)) diff --git a/scm/output-lib.scm b/scm/output-lib.scm index 6e2d06a66a..a191d65ae7 100644 --- a/scm/output-lib.scm +++ b/scm/output-lib.scm @@ -38,7 +38,7 @@ (define-public (print-circled-text-callback grob) (grob-interpret-markup grob (make-circle-markup - (ly:grob-property grob 'text)))) + (ly:grob-property grob 'text)))) (define-public (event-cause grob) (let ((cause (ly:grob-property grob 'cause))) @@ -50,8 +50,8 @@ (define-public (grob-interpret-markup grob text) (let* ((layout (ly:grob-layout grob)) - (defs (ly:output-def-lookup layout 'text-font-defaults)) - (props (ly:grob-alist-chain grob defs))) + (defs (ly:output-def-lookup layout 'text-font-defaults)) + (props (ly:grob-alist-chain grob defs))) (ly:text-interface::interpret-markup layout props text))) @@ -62,31 +62,31 @@ (define-public grob::unpure-horizontal-skylines-from-stencil (ly:make-unpure-pure-container - ly:grob::horizontal-skylines-from-stencil - ly:grob::pure-simple-horizontal-skylines-from-extents)) + ly:grob::horizontal-skylines-from-stencil + ly:grob::pure-simple-horizontal-skylines-from-extents)) (define-public grob::always-horizontal-skylines-from-stencil (ly:make-unpure-pure-container - ly:grob::horizontal-skylines-from-stencil)) + ly:grob::horizontal-skylines-from-stencil)) (define-public grob::unpure-vertical-skylines-from-stencil (ly:make-unpure-pure-container - ly:grob::vertical-skylines-from-stencil - ly:grob::pure-simple-vertical-skylines-from-extents)) + ly:grob::vertical-skylines-from-stencil + ly:grob::pure-simple-vertical-skylines-from-extents)) (define-public grob::always-vertical-skylines-from-stencil (ly:make-unpure-pure-container - ly:grob::vertical-skylines-from-stencil)) + ly:grob::vertical-skylines-from-stencil)) (define-public grob::always-vertical-skylines-from-element-stencils (ly:make-unpure-pure-container - ly:grob::vertical-skylines-from-element-stencils - ly:grob::pure-vertical-skylines-from-element-stencils)) + ly:grob::vertical-skylines-from-element-stencils + ly:grob::pure-vertical-skylines-from-element-stencils)) (define-public grob::always-horizontal-skylines-from-element-stencils (ly:make-unpure-pure-container - ly:grob::horizontal-skylines-from-element-stencils - ly:grob::pure-horizontal-skylines-from-element-stencils)) + ly:grob::horizontal-skylines-from-element-stencils + ly:grob::pure-horizontal-skylines-from-element-stencils)) ;; Using this as a callback for a grob's Y-extent promises ;; that the grob's stencil does not depend on line-spacing. @@ -101,7 +101,7 @@ (let* ((layout (ly:grob-layout grob)) (line-thickness (ly:output-def-lookup layout 'line-thickness))) - line-thickness)) + line-thickness)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; beam slope @@ -175,10 +175,10 @@ (ly:grob-array->list stems) '()))) (for-each - (lambda (g) - (ly:grob-set-property! g 'stem-begin-position 0) - (ly:grob-set-property! g 'length 0)) - stems-grobs) + (lambda (g) + (ly:grob-set-property! g 'stem-begin-position 0) + (ly:grob-set-property! g 'length 0)) + stems-grobs) pos)) ;; calculates each slope of a broken beam individually @@ -214,10 +214,10 @@ quant2)) (factor (/ (atan (abs slope1)) PI-OVER-TWO)) (base (cons-map - (lambda (x) - (+ (* (x quant1) (- 1 factor)) - (* (x quant2) factor))) - (cons car cdr)))) + (lambda (x) + (+ (* (x quant1) (- 1 factor)) + (* (x quant2) factor))) + (cons car cdr)))) (ly:beam::quanting grob base #f))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -238,16 +238,16 @@ (define-public side-position-interface::y-aligned-side (ly:make-unpure-pure-container - ly:side-position-interface::y-aligned-side - ly:side-position-interface::pure-y-aligned-side)) + ly:side-position-interface::y-aligned-side + ly:side-position-interface::pure-y-aligned-side)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; self-alignment stuff (define-public self-alignment-interface::y-aligned-on-self (ly:make-unpure-pure-container - ly:self-alignment-interface::y-aligned-on-self - ly:self-alignment-interface::pure-y-aligned-on-self)) + ly:self-alignment-interface::y-aligned-on-self + ly:self-alignment-interface::pure-y-aligned-on-self)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; staff symbol @@ -292,12 +292,12 @@ (define-public (note-head::calc-kievan-duration-log grob) (min 3 (ly:duration-log - (ly:event-property (event-cause grob) 'duration)))) + (ly:event-property (event-cause grob) 'duration)))) (define-public (note-head::calc-duration-log grob) (min 2 (ly:duration-log - (ly:event-property (event-cause grob) 'duration)))) + (ly:event-property (event-cause grob) 'duration)))) (define-public (dots::calc-dot-count grob) (ly:duration-dot-count @@ -305,11 +305,11 @@ (define-public (dots::calc-staff-position grob) (let* ((head (ly:grob-parent grob Y)) - (log (ly:grob-property head 'duration-log))) + (log (ly:grob-property head 'duration-log))) (cond ((or (not (grob::has-interface head 'rest-interface)) - (not (integer? log))) 0) + (not (integer? log))) 0) ((= log 7) 4) ((> log 4) 3) ((= log 0) -1) @@ -331,87 +331,87 @@ and duration-log @var{log}." ((harmonic) "0harmonic") ((harmonic-black) "2harmonic") ((harmonic-mixed) (if (<= log 1) "0harmonic" - "2harmonic")) + "2harmonic")) ((baroque) ;; Oops, I actually would not call this "baroque", but, for ;; backwards compatibility to 1.4, this is supposed to take ;; brevis, longa and maxima from the neo-mensural font and all ;; other note heads from the default font. -- jr (if (< log 0) - (string-append (number->string log) "neomensural") - (number->string log))) + (string-append (number->string log) "neomensural") + (number->string log))) ((altdefault) ;; Like default, but brevis is drawn with double vertical lines (if (= log -1) - (string-append (number->string log) "double") - (number->string log))) + (string-append (number->string log) "double") + (number->string log))) ((mensural) (string-append (number->string log) (symbol->string style))) ((petrucci) (if (< log 0) - (string-append (number->string log) "mensural") - (string-append (number->string log) (symbol->string style)))) + (string-append (number->string log) "mensural") + (string-append (number->string log) (symbol->string style)))) ((blackpetrucci) (if (< log 0) - (string-append (number->string log) "blackmensural") - (string-append (number->string log) (symbol->string style)))) + (string-append (number->string log) "blackmensural") + (string-append (number->string log) (symbol->string style)))) ((semipetrucci) (if (< log 0) - (string-append (number->string log) "semimensural") - (string-append (number->string log) "petrucci"))) + (string-append (number->string log) "semimensural") + (string-append (number->string log) "petrucci"))) ((neomensural) (string-append (number->string log) (symbol->string style))) ((kievan) (string-append (number->string log) "kievan")) (else (if (string-match "vaticana*|hufnagel*|medicaea*" (symbol->string style)) - (symbol->string style) - (string-append (number->string (max 0 log)) - (symbol->string style)))))) + (symbol->string style) + (string-append (number->string (max 0 log)) + (symbol->string style)))))) (define-public (note-head::calc-glyph-name grob) (let* ((style (ly:grob-property grob 'style)) - (log (if (string-match "kievan*" (symbol->string style)) - (min 3 (ly:grob-property grob 'duration-log)) - (min 2 (ly:grob-property grob 'duration-log))))) + (log (if (string-match "kievan*" (symbol->string style)) + (min 3 (ly:grob-property grob 'duration-log)) + (min 2 (ly:grob-property grob 'duration-log))))) (select-head-glyph style log))) (define-public (note-head::brew-ez-stencil grob) (let* ((log (ly:grob-property grob 'duration-log)) - (pitch (ly:event-property (event-cause grob) 'pitch)) - (pitch-index (ly:pitch-notename pitch)) - (note-names (ly:grob-property grob 'note-names)) - (pitch-string (if (and (vector? note-names) - (> (vector-length note-names) pitch-index)) - (vector-ref note-names pitch-index) - (string - (integer->char - (+ (modulo (+ pitch-index 2) 7) - (char->integer #\A)))))) - (staff-space (ly:staff-symbol-staff-space grob)) - (line-thickness (ly:staff-symbol-line-thickness grob)) - (stem (ly:grob-object grob 'stem)) - (stem-thickness (* (if (ly:grob? stem) - (ly:grob-property stem 'thickness) - 1.3) - line-thickness)) - (radius (/ (+ staff-space line-thickness) 2)) - (letter (markup #:center-align #:vcenter pitch-string)) - (filled-circle (markup #:draw-circle radius 0 #t))) + (pitch (ly:event-property (event-cause grob) 'pitch)) + (pitch-index (ly:pitch-notename pitch)) + (note-names (ly:grob-property grob 'note-names)) + (pitch-string (if (and (vector? note-names) + (> (vector-length note-names) pitch-index)) + (vector-ref note-names pitch-index) + (string + (integer->char + (+ (modulo (+ pitch-index 2) 7) + (char->integer #\A)))))) + (staff-space (ly:staff-symbol-staff-space grob)) + (line-thickness (ly:staff-symbol-line-thickness grob)) + (stem (ly:grob-object grob 'stem)) + (stem-thickness (* (if (ly:grob? stem) + (ly:grob-property stem 'thickness) + 1.3) + line-thickness)) + (radius (/ (+ staff-space line-thickness) 2)) + (letter (markup #:center-align #:vcenter pitch-string)) + (filled-circle (markup #:draw-circle radius 0 #t))) (ly:stencil-translate-axis (grob-interpret-markup grob (if (>= log 2) - (make-combine-markup - filled-circle - (make-with-color-markup white letter)) - (make-combine-markup - (make-combine-markup - filled-circle - (make-with-color-markup white (make-draw-circle-markup - (- radius stem-thickness) 0 #t))) - letter))) + (make-combine-markup + filled-circle + (make-with-color-markup white letter)) + (make-combine-markup + (make-combine-markup + filled-circle + (make-with-color-markup white (make-draw-circle-markup + (- radius stem-thickness) 0 #t))) + letter))) radius X))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -455,14 +455,14 @@ and duration-log @var{log}." (define-public (rhythmic-location->file-string a) (ly:format "~a.~a.~a" - (car a) - (ly:moment-main-numerator (cdr a)) - (ly:moment-main-denominator (cdr a)))) + (car a) + (ly:moment-main-numerator (cdr a)) + (ly:moment-main-denominator (cdr a)))) (define-public (rhythmic-location->string a) (ly:format "bar ~a ~a" - (car a) - (ly:moment->string (cdr a)))) + (car a) + (ly:moment->string (cdr a)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; break visibility @@ -483,7 +483,7 @@ and duration-log @var{log}." (define-public (shift-right-at-line-begin g) "Shift an item to the right, but only at the start of the line." (if (and (ly:item? g) - (equal? (ly:item-break-dir g) RIGHT)) + (equal? (ly:item-break-dir g) RIGHT)) (ly:grob-translate-axis! g 3.5 X))) (define-public (pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line grob) @@ -494,11 +494,11 @@ and duration-log @var{log}." (define-public (pure-from-neighbor-interface::extra-spacing-height grob) (let* ((height (ly:grob-pure-height grob grob 0 INFINITY-INT)) (from-neighbors (interval-union - height - (ly:axis-group-interface::pure-height - grob - 0 - INFINITY-INT)))) + height + (ly:axis-group-interface::pure-height + grob + 0 + INFINITY-INT)))) (coord-operation - from-neighbors height))) ;; If there are neighbors, we place the height at their midpoint @@ -528,7 +528,7 @@ and duration-log @var{log}." (ii (interval-intersection esh (cons -1.01 1.01)))) (if (pair? hsb) (cons (car (if (and (car hsb) - (ly:grob-property grob 'allow-span-bar)) + (ly:grob-property grob 'allow-span-bar)) esh ii)) (cdr (if (cdr hsb) esh ii))) ii))) @@ -537,8 +537,8 @@ and duration-log @var{log}." (let ((esh (pure-from-neighbor-interface::extra-spacing-height grob)) (to-staff (coord-operation - (interval-widen - '(0 . 0) - (ly:staff-symbol-staff-radius grob)) + '(0 . 0) + (ly:staff-symbol-staff-radius grob)) (ly:grob::stencil-height grob)))) (interval-union esh to-staff))) @@ -556,8 +556,8 @@ and duration-log @var{log}." (let ((ev (event-cause grob))) (format #f "~a:~a" - (ly:event-property ev 'denominator) - (ly:event-property ev 'numerator)))) + (ly:event-property ev 'denominator) + (ly:event-property ev 'numerator)))) ;; a formatter function, which is simply a wrapper around an existing ;; tuplet formatter function. It takes the value returned by the given @@ -566,21 +566,21 @@ and duration-log @var{log}." (let ((txt (if function (function grob) #f))) (if txt - (markup txt #:fontsize -5 #:note note UP) - (markup #:fontsize -5 #:note note UP)))) + (markup txt #:fontsize -5 #:note note UP) + (markup #:fontsize -5 #:note note UP)))) ;; Print a tuplet denominator with a different number than the one derived from ;; the actual tuplet fraction (define-public ((tuplet-number::non-default-tuplet-denominator-text denominator) - grob) + grob) (number->string (if denominator - denominator - (ly:event-property (event-cause grob) 'denominator)))) + denominator + (ly:event-property (event-cause grob) 'denominator)))) ;; Print a tuplet fraction with different numbers than the ones derived from ;; the actual tuplet fraction (define-public ((tuplet-number::non-default-tuplet-fraction-text - denominator numerator) grob) + denominator numerator) grob) (let* ((ev (event-cause grob)) (den (if denominator denominator (ly:event-property ev 'denominator))) (num (if numerator numerator (ly:event-property ev 'numerator)))) @@ -590,7 +590,7 @@ and duration-log @var{log}." ;; Print a tuplet fraction with note durations appended to the numerator and the ;; denominator (define-public ((tuplet-number::fraction-with-notes - denominatornote numeratornote) grob) + denominatornote numeratornote) grob) (let* ((ev (event-cause grob)) (denominator (ly:event-property ev 'denominator)) (numerator (ly:event-property ev 'numerator))) @@ -601,17 +601,17 @@ and duration-log @var{log}." ;; Print a tuplet fraction with note durations appended to the numerator and the ;; denominator (define-public ((tuplet-number::non-default-fraction-with-notes - denominator denominatornote numerator numeratornote) grob) + denominator denominatornote numerator numeratornote) grob) (let* ((ev (event-cause grob)) (den (if denominator denominator (ly:event-property ev 'denominator))) (num (if numerator numerator (ly:event-property ev 'numerator)))) (make-concat-markup (list - (make-simple-markup (format #f "~a" den)) - (markup #:fontsize -5 #:note denominatornote UP) - (make-simple-markup " : ") - (make-simple-markup (format #f "~a" num)) - (markup #:fontsize -5 #:note numeratornote UP))))) + (make-simple-markup (format #f "~a" den)) + (markup #:fontsize -5 #:note denominatornote UP) + (make-simple-markup " : ") + (make-simple-markup (format #f "~a" num)) + (markup #:fontsize -5 #:note numeratornote UP))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -625,7 +625,7 @@ and duration-log @var{log}." (define-public (rgb-color r g b) (list r g b)) -; predefined colors + ; predefined colors (define-public black '(0.0 0.0 0.0)) (define-public white '(1.0 1.0 1.0)) (define-public red '(1.0 0.0 0.0)) @@ -648,30 +648,30 @@ and duration-log @var{log}." ;; key signature (define-public (key-signature-interface::alteration-positions - entry c0-position grob) + entry c0-position grob) (let ((step (car entry)) - (alter (cdr entry))) + (alter (cdr entry))) (if (pair? step) - (list (+ (cdr step) (* (car step) 7) c0-position)) - (let* ((c-position (modulo c0-position 7)) - (positions - (if (< alter 0) - ;; See (flat|sharp)-positions in define-grob-properties.scm - (ly:grob-property grob 'flat-positions '(3)) - (ly:grob-property grob 'sharp-positions '(3)))) - (p (list-ref positions - (if (< c-position (length positions)) - c-position 0))) - (max-position (if (pair? p) (cdr p) p)) - (min-position (if (pair? p) (car p) (- max-position 6))) - (first-position (+ (modulo (- (+ c-position step) - min-position) - 7) - min-position))) - (define (prepend x l) (if (> x max-position) - l - (prepend (+ x 7) (cons x l)))) - (prepend first-position '()))))) + (list (+ (cdr step) (* (car step) 7) c0-position)) + (let* ((c-position (modulo c0-position 7)) + (positions + (if (< alter 0) + ;; See (flat|sharp)-positions in define-grob-properties.scm + (ly:grob-property grob 'flat-positions '(3)) + (ly:grob-property grob 'sharp-positions '(3)))) + (p (list-ref positions + (if (< c-position (length positions)) + c-position 0))) + (max-position (if (pair? p) (cdr p) p)) + (min-position (if (pair? p) (car p) (- max-position 6))) + (first-position (+ (modulo (- (+ c-position step) + min-position) + 7) + min-position))) + (define (prepend x l) (if (> x max-position) + l + (prepend (+ x 7) (cons x l)))) + (prepend first-position '()))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; annotations @@ -688,9 +688,9 @@ and duration-log @var{log}." idx (- n 1)))) (markup #:tiny (helper '("*" "†" "‡" "§" "¶") - "" - (remainder int 5) - (+ 1 (quotient int 5))))) + "" + (remainder int 5) + (+ 1 (quotient int 5))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; accidentals @@ -704,8 +704,8 @@ and duration-log @var{log}." (define-public accidental-interface::height (ly:make-unpure-pure-container - ly:accidental-interface::height - ly:accidental-interface::pure-height)) + ly:accidental-interface::height + ly:accidental-interface::pure-height)) (define-public cancellation-glyph-name-alist '((0 . "accidentals.natural"))) @@ -763,8 +763,8 @@ and duration-log @var{log}." (1/2 . "accidentals.mensural1"))) (define-public alteration-kievan-glyph-name-alist - '((-1/2 . "accidentals.kievanM1") - (1/2 . "accidentals.kievan1"))) + '((-1/2 . "accidentals.kievanM1") + (1/2 . "accidentals.kievan1"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; * Pitch Trill Heads @@ -772,8 +772,8 @@ and duration-log @var{log}." (define-public (parentheses-item::calc-parenthesis-stencils grob) (let* ((font (ly:grob-default-font grob)) - (lp (ly:font-get-glyph font "accidentals.leftparen")) - (rp (ly:font-get-glyph font "accidentals.rightparen"))) + (lp (ly:font-get-glyph font "accidentals.leftparen")) + (rp (ly:font-get-glyph font "accidentals.rightparen"))) (list lp rp))) @@ -784,26 +784,26 @@ and duration-log @var{log}." (width 0.5) ; should it be a property? (angularity 1.5) ; makes angle brackets (white-padding 0.1) ; should it be a property? - (lp (ly:stencil-aligned-to - (ly:stencil-aligned-to - (make-parenthesis-stencil y-extent - half-thickness - (- width) - angularity) - Y CENTER) - X RIGHT)) + (lp (ly:stencil-aligned-to + (ly:stencil-aligned-to + (make-parenthesis-stencil y-extent + half-thickness + (- width) + angularity) + Y CENTER) + X RIGHT)) (lp-x-extent - (interval-widen (ly:stencil-extent lp X) white-padding)) - (rp (ly:stencil-aligned-to - (ly:stencil-aligned-to - (make-parenthesis-stencil y-extent - half-thickness - width - angularity) - Y CENTER) - X LEFT)) - (rp-x-extent - (interval-widen (ly:stencil-extent rp X) white-padding))) + (interval-widen (ly:stencil-extent lp X) white-padding)) + (rp (ly:stencil-aligned-to + (ly:stencil-aligned-to + (make-parenthesis-stencil y-extent + half-thickness + width + angularity) + Y CENTER) + X LEFT)) + (rp-x-extent + (interval-widen (ly:stencil-extent rp X) white-padding))) (set! lp (ly:make-stencil (ly:stencil-expr lp) lp-x-extent (ly:stencil-extent lp Y))) @@ -815,14 +815,14 @@ and duration-log @var{log}." (define (parenthesize-elements grob . rest) (let* ((refp (if (null? rest) - grob - (car rest))) - (elts (ly:grob-object grob 'elements)) - (x-ext (ly:relative-group-extent elts refp X)) - (stencils (ly:grob-property grob 'stencils)) - (lp (car stencils)) - (rp (cadr stencils)) - (padding (ly:grob-property grob 'padding 0.1))) + grob + (car rest))) + (elts (ly:grob-object grob 'elements)) + (x-ext (ly:relative-group-extent elts refp X)) + (stencils (ly:grob-property grob 'stencils)) + (lp (car stencils)) + (rp (cadr stencils)) + (padding (ly:grob-property grob 'padding 0.1))) (ly:stencil-add (ly:stencil-translate-axis lp (- (car x-ext) padding) X) @@ -831,11 +831,11 @@ and duration-log @var{log}." (define-public (parentheses-item::print me) (let* ((elts (ly:grob-object me 'elements)) - (y-ref (ly:grob-common-refpoint-of-array me elts Y)) - (x-ref (ly:grob-common-refpoint-of-array me elts X)) - (stencil (parenthesize-elements me x-ref)) - (elt-y-ext (ly:relative-group-extent elts y-ref Y)) - (y-center (interval-center elt-y-ext))) + (y-ref (ly:grob-common-refpoint-of-array me elts Y)) + (x-ref (ly:grob-common-refpoint-of-array me elts X)) + (stencil (parenthesize-elements me x-ref)) + (elt-y-ext (ly:relative-group-extent elts y-ref Y)) + (y-center (interval-center elt-y-ext))) (ly:stencil-translate stencil @@ -874,57 +874,57 @@ and duration-log @var{log}." (< (abs (- a b)) 0.01)) (let* ((delta-y (* 0.5 (ly:grob-property spanner 'delta-position))) - (left-span (ly:spanner-bound spanner LEFT)) - (dots (if (and (grob::has-interface left-span 'note-head-interface) - (ly:grob? (ly:grob-object left-span 'dot))) - (ly:grob-object left-span 'dot) #f)) - - (right-span (ly:spanner-bound spanner RIGHT)) - (thickness (* (ly:grob-property spanner 'thickness) - (ly:output-def-lookup (ly:grob-layout spanner) - 'line-thickness))) - (padding (ly:grob-property spanner 'padding 0.5)) - (common (ly:grob-common-refpoint right-span - (ly:grob-common-refpoint spanner - left-span X) - X)) - (common-y (ly:grob-common-refpoint spanner left-span Y)) - (minimum-length (ly:grob-property spanner 'minimum-length 0.5)) - - (left-x (+ padding - (max - (interval-end (ly:grob-robust-relative-extent - left-span common X)) - (if - (and dots - (close - (ly:grob-relative-coordinate dots common-y Y) - (ly:grob-relative-coordinate spanner common-y Y))) - (interval-end - (ly:grob-robust-relative-extent dots common X)) - (- INFINITY-INT))))) - (right-x (max (- (interval-start - (ly:grob-robust-relative-extent right-span common X)) - padding) - (+ left-x minimum-length))) - (self-x (ly:grob-relative-coordinate spanner common X)) - (dx (- right-x left-x)) - (exp (list 'path thickness - `(quote - (rmoveto - ,(- left-x self-x) 0 - - rcurveto - ,(/ dx 3) - 0 - ,dx ,(* 0.66 delta-y) - ,dx ,delta-y))))) + (left-span (ly:spanner-bound spanner LEFT)) + (dots (if (and (grob::has-interface left-span 'note-head-interface) + (ly:grob? (ly:grob-object left-span 'dot))) + (ly:grob-object left-span 'dot) #f)) + + (right-span (ly:spanner-bound spanner RIGHT)) + (thickness (* (ly:grob-property spanner 'thickness) + (ly:output-def-lookup (ly:grob-layout spanner) + 'line-thickness))) + (padding (ly:grob-property spanner 'padding 0.5)) + (common (ly:grob-common-refpoint right-span + (ly:grob-common-refpoint spanner + left-span X) + X)) + (common-y (ly:grob-common-refpoint spanner left-span Y)) + (minimum-length (ly:grob-property spanner 'minimum-length 0.5)) + + (left-x (+ padding + (max + (interval-end (ly:grob-robust-relative-extent + left-span common X)) + (if + (and dots + (close + (ly:grob-relative-coordinate dots common-y Y) + (ly:grob-relative-coordinate spanner common-y Y))) + (interval-end + (ly:grob-robust-relative-extent dots common X)) + (- INFINITY-INT))))) + (right-x (max (- (interval-start + (ly:grob-robust-relative-extent right-span common X)) + padding) + (+ left-x minimum-length))) + (self-x (ly:grob-relative-coordinate spanner common X)) + (dx (- right-x left-x)) + (exp (list 'path thickness + `(quote + (rmoveto + ,(- left-x self-x) 0 + + rcurveto + ,(/ dx 3) + 0 + ,dx ,(* 0.66 delta-y) + ,dx ,delta-y))))) (ly:make-stencil exp (cons (- left-x self-x) (- right-x self-x)) (cons (min 0 delta-y) - (max 0 delta-y))))) + (max 0 delta-y))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -932,24 +932,24 @@ and duration-log @var{log}." (define-public (grace-spacing::calc-shortest-duration grob) (let* ((cols (ly:grob-object grob 'columns)) - (get-difference - (lambda (idx) - (ly:moment-sub (ly:grob-property - (ly:grob-array-ref cols (1+ idx)) 'when) - (ly:grob-property - (ly:grob-array-ref cols idx) 'when)))) - - (moment-min (lambda (x y) - (cond - ((and x y) - (if (ly:moment<? x y) - x - y)) - (x x) - (y y))))) + (get-difference + (lambda (idx) + (ly:moment-sub (ly:grob-property + (ly:grob-array-ref cols (1+ idx)) 'when) + (ly:grob-property + (ly:grob-array-ref cols idx) 'when)))) + + (moment-min (lambda (x y) + (cond + ((and x y) + (if (ly:moment<? x y) + x + y)) + (x x) + (y y))))) (fold moment-min #f (map get-difference - (iota (1- (ly:grob-array-length cols))))))) + (iota (1- (ly:grob-array-length cols))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -968,8 +968,8 @@ and duration-log @var{log}." (define-public (stroke-finger::calc-text grob) (let ((event (event-cause grob))) (or (ly:event-property event 'text #f) - (vector-ref (ly:grob-property grob 'digit-names) - (1- (max 1 + (vector-ref (ly:grob-property grob 'digit-names) + (1- (max 1 (min 5 (ly:event-property event 'digit)))))))) @@ -989,18 +989,18 @@ changing @code{'attach-dir} and @code{'padding}. Reads the between the two text elements." (let ((left-bound (ly:spanner-bound grob LEFT))) (if (grob::has-interface left-bound 'dynamic-text-interface) - (let* ((details (ly:grob-property grob 'bound-details)) - (left-details (ly:assoc-get 'left details)) - (my-padding (ly:assoc-get 'padding left-details)) - (script-padding (ly:grob-property left-bound 'right-padding 0))) - - (and (number? my-padding) - (ly:grob-set-nested-property! grob - '(bound-details left attach-dir) - RIGHT) - (ly:grob-set-nested-property! grob - '(bound-details left padding) - (+ my-padding script-padding))))))) + (let* ((details (ly:grob-property grob 'bound-details)) + (left-details (ly:assoc-get 'left details)) + (my-padding (ly:assoc-get 'padding left-details)) + (script-padding (ly:grob-property left-bound 'right-padding 0))) + + (and (number? my-padding) + (ly:grob-set-nested-property! grob + '(bound-details left attach-dir) + RIGHT) + (ly:grob-set-nested-property! grob + '(bound-details left padding) + (+ my-padding script-padding))))))) (define-public ((elbowed-hairpin coords mirrored?) grob) "Create hairpin based on a list of @var{coords} in @code{(cons x y)} @@ -1028,39 +1028,39 @@ and draws the stencil based on its coordinates. (list (car pair) (cdr pair))) (define (normalize-coords goods x y) (map - (lambda (coord) - (cons (* x (car coord)) (* y (cdr coord)))) - goods)) + (lambda (coord) + (cons (* x (car coord)) (* y (cdr coord)))) + goods)) (define (my-c-p-s points thick decresc?) (make-connected-path-stencil - points - thick - (if decresc? -1.0 1.0) - 1.0 - #f - #f)) - ; outer let to trigger suicide + points + thick + (if decresc? -1.0 1.0) + 1.0 + #f + #f)) + ; outer let to trigger suicide (let ((sten (ly:hairpin::print grob))) (if (grob::is-live? grob) - (let* ((decresc? (eq? (ly:grob-property grob 'grow-direction) LEFT)) - (thick (ly:grob-property grob 'thickness 0.1)) - (thick (* thick (layout-line-thickness grob))) - (xex (ly:stencil-extent sten X)) - (lenx (interval-length xex)) - (yex (ly:stencil-extent sten Y)) - (leny (interval-length yex)) - (xtrans (+ (car xex) (if decresc? lenx 0))) - (ytrans (car yex)) - (uplist (map pair-to-list - (normalize-coords coords lenx (/ leny 2)))) - (downlist (map pair-to-list - (normalize-coords coords lenx (/ leny -2))))) - (ly:stencil-translate - (ly:stencil-add - (my-c-p-s uplist thick decresc?) - (if mirrored? (my-c-p-s downlist thick decresc?) empty-stencil)) - (cons xtrans ytrans))) - '()))) + (let* ((decresc? (eq? (ly:grob-property grob 'grow-direction) LEFT)) + (thick (ly:grob-property grob 'thickness 0.1)) + (thick (* thick (layout-line-thickness grob))) + (xex (ly:stencil-extent sten X)) + (lenx (interval-length xex)) + (yex (ly:stencil-extent sten Y)) + (leny (interval-length yex)) + (xtrans (+ (car xex) (if decresc? lenx 0))) + (ytrans (car yex)) + (uplist (map pair-to-list + (normalize-coords coords lenx (/ leny 2)))) + (downlist (map pair-to-list + (normalize-coords coords lenx (/ leny -2))))) + (ly:stencil-translate + (ly:stencil-add + (my-c-p-s uplist thick decresc?) + (if mirrored? (my-c-p-s downlist thick decresc?) empty-stencil)) + (cons xtrans ytrans))) + '()))) (define-public flared-hairpin (elbowed-hairpin '((0.95 . 0.4) (1.0 . 1.0)) #t)) @@ -1077,8 +1077,8 @@ and draws the stencil based on its coordinates. (let ((text (ly:grob-property grob 'text))) (grob-interpret-markup grob (if (string? text) - (make-tied-lyric-markup text) - text)))) + (make-tied-lyric-markup text) + text)))) (define-public ((grob::calc-property-by-copy prop) grob) (ly:event-property (event-cause grob) prop)) @@ -1112,8 +1112,8 @@ parent or the parent has no setting." (define-public slur::height (ly:make-unpure-pure-container - ly:slur::height - ly:slur::pure-height)) + ly:slur::height + ly:slur::pure-height)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; scripts @@ -1121,10 +1121,10 @@ parent or the parent has no setting." (define-public (script-interface::calc-x-offset grob) (ly:grob-property grob 'positioning-done) (let* ((shift (ly:grob-property grob 'toward-stem-shift 0.0)) - (note-head-location - (ly:self-alignment-interface::centered-on-x-parent grob)) - (note-head-grob (ly:grob-parent grob X)) - (stem-grob (ly:grob-object note-head-grob 'stem))) + (note-head-location + (ly:self-alignment-interface::centered-on-x-parent grob)) + (note-head-grob (ly:grob-parent grob X)) + (stem-grob (ly:grob-object note-head-grob 'stem))) (+ note-head-location ;; If the property 'toward-stem-shift is defined and the script @@ -1132,15 +1132,15 @@ parent or the parent has no setting." ;; Since scripts can also be over skips, we need to check whether ;; the grob has a stem at all. (if (ly:grob? stem-grob) - (let ((dir1 (ly:grob-property grob 'direction)) - (dir2 (ly:grob-property stem-grob 'direction))) - (if (equal? dir1 dir2) - (let* ((common-refp (ly:grob-common-refpoint grob stem-grob X)) - (stem-location - (ly:grob-relative-coordinate stem-grob common-refp X))) - (* shift (- stem-location note-head-location))) - 0.0)) - 0.0)))) + (let ((dir1 (ly:grob-property grob 'direction)) + (dir2 (ly:grob-property stem-grob 'direction))) + (if (equal? dir1 dir2) + (let* ((common-refp (ly:grob-common-refpoint grob stem-grob X)) + (stem-location + (ly:grob-relative-coordinate stem-grob common-refp X))) + (* shift (- stem-location note-head-location))) + 0.0)) + 0.0)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1148,48 +1148,48 @@ parent or the parent has no setting." (define-public (system-start-text::print grob) (let* ((left-bound (ly:spanner-bound grob LEFT)) - (left-mom (ly:grob-property left-bound 'when)) - (name (if (moment<=? left-mom ZERO-MOMENT) - (ly:grob-property grob 'long-text) - (ly:grob-property grob 'text)))) + (left-mom (ly:grob-property left-bound 'when)) + (name (if (moment<=? left-mom ZERO-MOMENT) + (ly:grob-property grob 'long-text) + (ly:grob-property grob 'text)))) (if (and (markup? name) - (!= (ly:item-break-dir left-bound) CENTER)) + (!= (ly:item-break-dir left-bound) CENTER)) - (grob-interpret-markup grob name) - (ly:grob-suicide! grob)))) + (grob-interpret-markup grob name) + (ly:grob-suicide! grob)))) (define-public (system-start-text::calc-x-offset grob) (let* ((left-bound (ly:spanner-bound grob LEFT)) - (left-mom (ly:grob-property left-bound 'when)) - (layout (ly:grob-layout grob)) - (indent (ly:output-def-lookup layout - (if (moment<=? left-mom ZERO-MOMENT) - 'indent - 'short-indent) - 0.0)) - (system (ly:grob-system grob)) - (my-extent (ly:grob-extent grob system X)) - (elements (ly:grob-object system 'elements)) - (common (ly:grob-common-refpoint-of-array system elements X)) - (total-ext empty-interval) - (align-x (ly:grob-property grob 'self-alignment-X 0)) - (padding (min 0 (- (interval-length my-extent) indent))) - (right-padding (- padding - (/ (* padding (1+ align-x)) 2)))) + (left-mom (ly:grob-property left-bound 'when)) + (layout (ly:grob-layout grob)) + (indent (ly:output-def-lookup layout + (if (moment<=? left-mom ZERO-MOMENT) + 'indent + 'short-indent) + 0.0)) + (system (ly:grob-system grob)) + (my-extent (ly:grob-extent grob system X)) + (elements (ly:grob-object system 'elements)) + (common (ly:grob-common-refpoint-of-array system elements X)) + (total-ext empty-interval) + (align-x (ly:grob-property grob 'self-alignment-X 0)) + (padding (min 0 (- (interval-length my-extent) indent))) + (right-padding (- padding + (/ (* padding (1+ align-x)) 2)))) ;; compensate for the variation in delimiter extents by ;; calculating an X-offset correction based on united extents ;; of all delimiters in this system (let unite-delims ((l (ly:grob-array-length elements))) (if (> l 0) - (let ((elt (ly:grob-array-ref elements (1- l)))) + (let ((elt (ly:grob-array-ref elements (1- l)))) - (if (grob::has-interface elt 'system-start-delimiter-interface) - (let ((dims (ly:grob-extent elt common X))) - (if (interval-sane? dims) - (set! total-ext (interval-union total-ext dims))))) - (unite-delims (1- l))))) + (if (grob::has-interface elt 'system-start-delimiter-interface) + (let ((dims (ly:grob-extent elt common X))) + (if (interval-sane? dims) + (set! total-ext (interval-union total-ext dims))))) + (unite-delims (1- l))))) (+ (ly:side-position-interface::x-aligned-side grob) @@ -1205,25 +1205,25 @@ parent or the parent has no setting." (ly:grob-array->list elements)))) (let* ((left-bound (ly:spanner-bound grob LEFT)) - (live-elts (live-elements-list grob)) - (system (ly:grob-system grob)) - (extent empty-interval)) + (live-elts (live-elements-list grob)) + (system (ly:grob-system grob)) + (extent empty-interval)) (if (and (pair? live-elts) - (interval-sane? (ly:grob-extent grob system Y))) - (let get-extent ((lst live-elts)) - (if (pair? lst) - (let ((axis-group (car lst))) - - (if (and (ly:spanner? axis-group) - (equal? (ly:spanner-bound axis-group LEFT) - left-bound)) - (set! extent (add-point extent - (ly:grob-relative-coordinate - axis-group system Y)))) - (get-extent (cdr lst))))) - ;; no live axis group(s) for this instrument name -> remove from system - (ly:grob-suicide! grob)) + (interval-sane? (ly:grob-extent grob system Y))) + (let get-extent ((lst live-elts)) + (if (pair? lst) + (let ((axis-group (car lst))) + + (if (and (ly:spanner? axis-group) + (equal? (ly:spanner-bound axis-group LEFT) + left-bound)) + (set! extent (add-point extent + (ly:grob-relative-coordinate + axis-group system Y)))) + (get-extent (cdr lst))))) + ;; no live axis group(s) for this instrument name -> remove from system + (ly:grob-suicide! grob)) (+ (ly:self-alignment-interface::y-aligned-on-self grob) @@ -1235,8 +1235,8 @@ parent or the parent has no setting." (define-public axis-group-interface::height (ly:make-unpure-pure-container - ly:axis-group-interface::height - ly:axis-group-interface::pure-height)) + ly:axis-group-interface::height + ly:axis-group-interface::pure-height)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ambitus @@ -1245,32 +1245,32 @@ parent or the parent has no setting." (let ((heads (ly:grob-object grob 'note-heads))) (if (and (ly:grob-array? heads) - (= (ly:grob-array-length heads) 2)) - (let* ((common (ly:grob-common-refpoint-of-array grob heads Y)) - (head-down (ly:grob-array-ref heads 0)) - (head-up (ly:grob-array-ref heads 1)) - (gap (ly:grob-property grob 'gap 0.35)) - (point-min (+ (interval-end (ly:grob-extent head-down common Y)) - gap)) - (point-max (- (interval-start (ly:grob-extent head-up common Y)) - gap))) - - (if (< point-min point-max) - (let* ((layout (ly:grob-layout grob)) - (line-thick (ly:output-def-lookup layout 'line-thickness)) - (blot (ly:output-def-lookup layout 'blot-diameter)) - (grob-thick (ly:grob-property grob 'thickness 2)) - (width (* line-thick grob-thick)) - (x-ext (symmetric-interval (/ width 2))) - (y-ext (cons point-min point-max)) - (line (ly:round-filled-box x-ext y-ext blot)) - (y-coord (ly:grob-relative-coordinate grob common Y))) - - (ly:stencil-translate-axis line (- y-coord) Y)) - empty-stencil)) - (begin - (ly:grob-suicide! grob) - (list))))) + (= (ly:grob-array-length heads) 2)) + (let* ((common (ly:grob-common-refpoint-of-array grob heads Y)) + (head-down (ly:grob-array-ref heads 0)) + (head-up (ly:grob-array-ref heads 1)) + (gap (ly:grob-property grob 'gap 0.35)) + (point-min (+ (interval-end (ly:grob-extent head-down common Y)) + gap)) + (point-max (- (interval-start (ly:grob-extent head-up common Y)) + gap))) + + (if (< point-min point-max) + (let* ((layout (ly:grob-layout grob)) + (line-thick (ly:output-def-lookup layout 'line-thickness)) + (blot (ly:output-def-lookup layout 'blot-diameter)) + (grob-thick (ly:grob-property grob 'thickness 2)) + (width (* line-thick grob-thick)) + (x-ext (symmetric-interval (/ width 2))) + (y-ext (cons point-min point-max)) + (line (ly:round-filled-box x-ext y-ext blot)) + (y-coord (ly:grob-relative-coordinate grob common Y))) + + (ly:stencil-translate-axis line (- y-coord) Y)) + empty-stencil)) + (begin + (ly:grob-suicide! grob) + (list))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; laissez-vibrer tie @@ -1278,7 +1278,7 @@ parent or the parent has no setting." ;; needed so we can make laissez-vibrer a pure print ;; (define-public (laissez-vibrer::print grob) - (ly:tie::print grob)) + (ly:tie::print grob)) (define-public (semi-tie::calc-cross-staff grob) (let* ((note-head (ly:grob-object grob 'note-head)) @@ -1292,7 +1292,7 @@ parent or the parent has no setting." (define-public (volta-bracket-interface::pure-height grob start end) (let ((edge-height (ly:grob-property grob 'edge-height))) (if (number-pair? edge-height) - (let ((smaller (min (car edge-height) (cdr edge-height))) - (larger (max (car edge-height) (cdr edge-height)))) - (interval-union '(0 . 0) (cons smaller larger))) - '(0 . 0)))) + (let ((smaller (min (car edge-height) (cdr edge-height))) + (larger (max (car edge-height) (cdr edge-height)))) + (interval-union '(0 . 0) (cons smaller larger))) + '(0 . 0)))) diff --git a/scm/output-ps.scm b/scm/output-ps.scm index dd92175feb..813211f060 100644 --- a/scm/output-ps.scm +++ b/scm/output-ps.scm @@ -28,12 +28,12 @@ #:re-export (quote)) (use-modules (guile) - (ice-9 regex) - (ice-9 optargs) - (srfi srfi-1) - (srfi srfi-13) - (scm framework-ps) - (lily)) + (ice-9 regex) + (ice-9 optargs) + (srfi srfi-1) + (srfi srfi-13) + (scm framework-ps) + (lily)) ;;; helper functions, not part of output interface ;;; @@ -45,10 +45,10 @@ (define (str4 num) (if (or (nan? num) (inf? num)) (begin - (ly:warning (_ "Found infinity or nan in output. Substituting 0.0")) - (if (ly:get-option 'strict-infinity-checking) - (exit 1)) - "0.0") + (ly:warning (_ "Found infinity or nan in output. Substituting 0.0")) + (if (ly:get-option 'strict-infinity-checking) + (exit 1)) + "0.0") (ly:number->string num))) (define (number-pair->string4 numpair) @@ -60,15 +60,15 @@ (define (char font i) (ly:format "~a (\\~a) show" - (ps-font-command font) - (ly:inexact->string i 8))) + (ps-font-command font) + (ly:inexact->string i 8))) (define (circle radius thick fill) (ly:format "~a ~4f ~4f draw_circle" (if fill - "true" - "false") + "true" + "false") radius thick)) (define (start-enclosing-id-node s) @@ -79,34 +79,34 @@ (define (dashed-line thick on off dx dy phase) (ly:format "~4f ~4f ~4f [ ~4f ~4f ] ~4f draw_dashed_line" - dx - dy - thick - on - off - phase)) + dx + dy + thick + on + off + phase)) (define (draw-line thick x1 y1 x2 y2) (ly:format "~4f ~4f ~4f ~4f ~4f draw_line" - (- x2 x1) (- y2 y1) - x1 y1 thick)) + (- x2 x1) (- y2 y1) + x1 y1 thick)) (define (partial-ellipse x-radius y-radius start-angle end-angle thick connect fill) (ly:format "~a ~a ~4f ~4f ~4f ~4f ~4f draw_partial_ellipse" - (if fill "true" "false") - (if connect "true" "false") - x-radius - y-radius - start-angle - end-angle - thick)) + (if fill "true" "false") + (if connect "true" "false") + x-radius + y-radius + start-angle + end-angle + thick)) (define (ellipse x-radius y-radius thick fill) (ly:format "~a ~4f ~4f ~4f draw_ellipse" (if fill - "true" - "false") + "true" + "false") x-radius y-radius thick)) (define (embedded-ps string) @@ -114,78 +114,78 @@ (define (glyph-string pango-font postscript-font-name - size - cid? - w-x-y-named-glyphs) + size + cid? + w-x-y-named-glyphs) (define (glyph-spec w h x y g) ; h not used (let ((prefix (if (string? g) "/" ""))) (ly:format "~4f ~4f ~4f ~a~a" - w x y - prefix g))) + w x y + prefix g))) (ly:format (if cid? -"/~a /CIDFont findresource ~a output-scale div scalefont setfont + "/~a /CIDFont findresource ~a output-scale div scalefont setfont ~a ~a print_glyphs" -"/~a ~a output-scale div selectfont + "/~a ~a output-scale div selectfont ~a ~a print_glyphs") - postscript-font-name - size - (string-join (map (lambda (x) (apply glyph-spec x)) - (reverse w-x-y-named-glyphs)) "\n") - (length w-x-y-named-glyphs))) + postscript-font-name + size + (string-join (map (lambda (x) (apply glyph-spec x)) + (reverse w-x-y-named-glyphs)) "\n") + (length w-x-y-named-glyphs))) (define (grob-cause offset grob) (if (ly:get-option 'point-and-click) (let* ((cause (ly:grob-property grob 'cause)) - (music-origin (if (ly:stream-event? cause) - (ly:event-property cause 'origin))) - (point-and-click (ly:get-option 'point-and-click))) - (if (and - (ly:input-location? music-origin) - (cond ((boolean? point-and-click) point-and-click) - ((symbol? point-and-click) - (ly:in-event-class? cause point-and-click)) - (else (any (lambda (t) - (ly:in-event-class? cause t)) - point-and-click)))) - (let* ((location (ly:input-file-line-char-column music-origin)) - (raw-file (car location)) - (file (if (is-absolute? raw-file) - raw-file - (string-append (ly-getcwd) "/" raw-file))) - (x-ext (ly:grob-extent grob grob X)) - (y-ext (ly:grob-extent grob grob Y))) - - (if (and (< 0 (interval-length x-ext)) - (< 0 (interval-length y-ext))) - (ly:format "~4f ~4f ~4f ~4f (textedit://~a:~a:~a:~a) mark_URI\n" - (+ (car offset) (car x-ext)) - (+ (cdr offset) (car y-ext)) - (+ (car offset) (cdr x-ext)) - (+ (cdr offset) (cdr y-ext)) - - ;; Backslashes are not valid - ;; file URI path separators. - (ly:string-percent-encode - (ly:string-substitute "\\" "/" file)) - - (cadr location) - (caddr location) - (1+ (cadddr location))) - "")) - "")) + (music-origin (if (ly:stream-event? cause) + (ly:event-property cause 'origin))) + (point-and-click (ly:get-option 'point-and-click))) + (if (and + (ly:input-location? music-origin) + (cond ((boolean? point-and-click) point-and-click) + ((symbol? point-and-click) + (ly:in-event-class? cause point-and-click)) + (else (any (lambda (t) + (ly:in-event-class? cause t)) + point-and-click)))) + (let* ((location (ly:input-file-line-char-column music-origin)) + (raw-file (car location)) + (file (if (is-absolute? raw-file) + raw-file + (string-append (ly-getcwd) "/" raw-file))) + (x-ext (ly:grob-extent grob grob X)) + (y-ext (ly:grob-extent grob grob Y))) + + (if (and (< 0 (interval-length x-ext)) + (< 0 (interval-length y-ext))) + (ly:format "~4f ~4f ~4f ~4f (textedit://~a:~a:~a:~a) mark_URI\n" + (+ (car offset) (car x-ext)) + (+ (cdr offset) (car y-ext)) + (+ (car offset) (cdr x-ext)) + (+ (cdr offset) (cdr y-ext)) + + ;; Backslashes are not valid + ;; file URI path separators. + (ly:string-percent-encode + (ly:string-substitute "\\" "/" file)) + + (cadr location) + (caddr location) + (1+ (cadddr location))) + "")) + "")) "")) (define (named-glyph font glyph) (ly:format "~a /~a glyphshow " ;;Why is there a space at the end? - (ps-font-command font) - glyph)) + (ps-font-command font) + glyph)) (define (no-origin) "") @@ -197,24 +197,24 @@ (define (polygon points blot-diameter filled?) (ly:format "~a ~4l ~a ~4f draw_polygon" - (if filled? "true" "false") - points - (- (/ (length points) 2) 1) - blot-diameter)) + (if filled? "true" "false") + points + (- (/ (length points) 2) 1) + blot-diameter)) (define (round-filled-box left right bottom top blotdiam) (let* ((halfblot (/ blotdiam 2)) - (x (- halfblot left)) - (width (- right (+ halfblot x))) - (y (- halfblot bottom)) - (height (- top (+ halfblot y)))) + (x (- halfblot left)) + (width (- right (+ halfblot x))) + (y (- halfblot bottom)) + (height (- top (+ halfblot y)))) (ly:format "~4l draw_round_box" - (list width height x y blotdiam)))) + (list width height x y blotdiam)))) ;; save current color on stack and set new color (define (setcolor r g b) (ly:format "gsave ~4l setrgbcolor\n" - (list r g b))) + (list r g b))) ;; restore color from stack (define (resetcolor) "grestore\n") @@ -222,9 +222,9 @@ ;; rotation around given point (define (setrotation ang x y) (ly:format "gsave ~4l translate ~a rotate ~4l translate\n" - (list x y) - ang - (list (* -1 x) (* -1 y)))) + (list x y) + ang + (list (* -1 x) (* -1 y)))) (define (resetrotation ang x y) "grestore ") @@ -234,55 +234,55 @@ (define (url-link url x y) (ly:format "~a ~a currentpoint vector_add ~a ~a currentpoint vector_add (~a) mark_URI" - (car x) - (car y) - (cdr x) - (cdr y) - url)) + (car x) + (car y) + (cdr x) + (cdr y) + url)) (define (page-link page-no x y) (if (number? page-no) - (ly:format "~a ~a currentpoint vector_add ~a ~a currentpoint vector_add ~a mark_page_link" - (car x) - (car y) - (cdr x) - (cdr y) - page-no) - "")) + (ly:format "~a ~a currentpoint vector_add ~a ~a currentpoint vector_add ~a mark_page_link" + (car x) + (car y) + (cdr x) + (cdr y) + page-no) + "")) (define* (path thickness exps #:optional (cap 'round) (join 'round) (fill? #f)) (define (convert-path-exps exps) (if (pair? exps) - (let* - ((head (car exps)) - (rest (cdr exps)) - (arity - (cond - ((memq head '(rmoveto rlineto lineto moveto)) 2) - ((memq head '(rcurveto curveto)) 6) - ((eq? head 'closepath) 0) - (else 1))) - (args (take rest arity)) - ) - - ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here. - (cons (ly:format - "~l ~a " - args - head) - (convert-path-exps (drop rest arity)))) - '())) + (let* + ((head (car exps)) + (rest (cdr exps)) + (arity + (cond + ((memq head '(rmoveto rlineto lineto moveto)) 2) + ((memq head '(rcurveto curveto)) 6) + ((eq? head 'closepath) 0) + (else 1))) + (args (take rest arity)) + ) + + ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here. + (cons (ly:format + "~l ~a " + args + head) + (convert-path-exps (drop rest arity)))) + '())) (let ((cap-numeric (case cap ((butt) 0) ((round) 1) ((square) 2) - (else (begin - (ly:warning (_ "unknown line-cap-style: ~S") - (symbol->string cap)) - 1)))) - (join-numeric (case join ((miter) 0) ((round) 1) ((bevel) 2) - (else (begin - (ly:warning (_ "unknown line-join-style: ~S") - (symbol->string join)) - 1))))) + (else (begin + (ly:warning (_ "unknown line-cap-style: ~S") + (symbol->string cap)) + 1)))) + (join-numeric (case join ((miter) 0) ((round) 1) ((bevel) 2) + (else (begin + (ly:warning (_ "unknown line-join-style: ~S") + (symbol->string join)) + 1))))) (ly:format "gsave currentpoint translate ~a setlinecap ~a setlinejoin ~a setlinewidth @@ -295,7 +295,7 @@ (define (setscale x y) (ly:format "gsave ~4l scale\n" - (list x y))) + (list x y))) (define (resetscale) "grestore\n") diff --git a/scm/output-socket.scm b/scm/output-socket.scm index 352ff2989d..3532fc9732 100644 --- a/scm/output-socket.scm +++ b/scm/output-socket.scm @@ -6,43 +6,43 @@ #:re-export (quote)) (use-modules (guile) - (srfi srfi-1) - (srfi srfi-13) - (lily)) + (srfi srfi-1) + (srfi srfi-13) + (lily)) (define format ergonomic-simple-format) (define (event-cause grob) (let* - ((cause (ly:grob-property grob 'cause))) + ((cause (ly:grob-property grob 'cause))) (if (ly:stream-event? cause) - cause - #f))) + cause + #f))) (define (grob-bbox grob offset) (let* - ((x-ext (ly:grob-extent grob grob X)) - (y-ext (ly:grob-extent grob grob Y)) - (x (car offset)) - (y (cdr offset))) + ((x-ext (ly:grob-extent grob grob X)) + (y-ext (ly:grob-extent grob grob Y)) + (x (car offset)) + (y (cdr offset))) (if (interval-empty? x-ext) - (set! x-ext '(0 . 0))) + (set! x-ext '(0 . 0))) (if (interval-empty? y-ext) - (set! y-ext '(0 . 0))) + (set! y-ext '(0 . 0))) (list (+ x (car x-ext)) - (+ y (car y-ext)) - (+ x (cdr x-ext)) - (+ y (cdr y-ext))))) + (+ y (car y-ext)) + (+ x (cdr x-ext)) + (+ y (cdr y-ext))))) (define (escape-string str) (string-regexp-substitute - " " "\\040" - (string-regexp-substitute "\"" "\\\"" str))) + " " "\\040" + (string-regexp-substitute "\"" "\\\"" str))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; stencil commands @@ -50,26 +50,26 @@ (define (draw-line thick x1 y1 x2 y2) (format #f "drawline ~a ~a ~a ~a ~a" - thick x1 y2 x2 y2)) + thick x1 y2 x2 y2)) (define (grob-cause offset grob) (let* - ((cause (event-cause grob)) - (tag (if (and cause (integer? (ly:event-property cause 'input-tag))) - (ly:event-property cause 'input-tag) - -1)) - (name (assoc-get 'name (ly:grob-property grob 'meta)))) + ((cause (event-cause grob)) + (tag (if (and cause (integer? (ly:event-property cause 'input-tag))) + (ly:event-property cause 'input-tag) + -1)) + (name (assoc-get 'name (ly:grob-property grob 'meta)))) (apply format #f - "cause ~a \"~a\" ~a ~a ~a ~a\n" tag name - (grob-bbox grob offset)))) + "cause ~a \"~a\" ~a ~a ~a ~a\n" tag name + (grob-bbox grob offset)))) (define (named-glyph font glyph) (format #f "glyphshow ~a \"~a\" ~a \"~a\"" - (ly:font-glyph-name-to-charcode font glyph) - (ly:font-name font) - (modified-font-metric-font-scaling font) - glyph)) + (ly:font-glyph-name-to-charcode font glyph) + (ly:font-name font) + (modified-font-metric-font-scaling font) + glyph)) (define (no-origin) "nocause\n") @@ -81,16 +81,16 @@ (define (polygon xy-coords blot do-fill) (format #f "polygon ~a ~a ~a" - blot - (if do-fill "True" "False") - (string-join (map number->string xy-coords)))) + blot + (if do-fill "True" "False") + (string-join (map number->string xy-coords)))) (define (round-filled-box breapth width depth height blot-diameter) (format #f "draw_round_box ~a ~a ~a ~a ~a" - breapth width depth height blot-diameter)) + breapth width depth height blot-diameter)) (define (utf-8-string descr string) (format #f "utf-8 \"~a\" \"~a\"" - (escape-string descr) - ;; don't want unescaped spaces. - (escape-string string))) + (escape-string descr) + ;; don't want unescaped spaces. + (escape-string string))) diff --git a/scm/output-svg.scm b/scm/output-svg.scm index 354bff4e05..8e2c532a3b 100644 --- a/scm/output-svg.scm +++ b/scm/output-svg.scm @@ -23,15 +23,15 @@ ;;; set by framework-gnome.scm (define paper #f) - + (use-modules - (guile) - (ice-9 regex) - (ice-9 format) - (ice-9 optargs) - (lily) - (srfi srfi-1) - (srfi srfi-13)) + (guile) + (ice-9 regex) + (ice-9 format) + (ice-9 optargs) + (lily) + (srfi srfi-1) + (srfi srfi-13)) (define fancy-format format) (define format ergonomic-simple-format) @@ -41,13 +41,13 @@ ;; Helper functions (define-public (attributes attributes-alist) (apply string-append - (map (lambda (x) - (let ((attr (car x)) - (value (cdr x))) - (if (number? value) - (set! value (ly:format "~4f" value))) - (format #f " ~s=\"~a\"" attr value))) - attributes-alist))) + (map (lambda (x) + (let ((attr (car x)) + (value (cdr x))) + (if (number? value) + (set! value (ly:format "~4f" value))) + (format #f " ~s=\"~a\"" attr value))) + attributes-alist))) (define-public (eo entity . attributes-alist) "o = open" @@ -74,7 +74,7 @@ (if (equal? string "") (apply eoc entity attributes-alist) (string-append - (apply eo (cons entity attributes-alist)) string (ec entity)))) + (apply eo (cons entity attributes-alist)) string (ec entity)))) (define (offset->point o) (ly:format "~4f ~4f" (car o) (- (cdr o)))) @@ -82,21 +82,21 @@ (define (number-list->point lst) (define (helper lst) (if (null? lst) - '() - (cons (format #f "~S ~S" (car lst) (- (cadr lst))) - (helper (cddr lst))))) + '() + (cons (format #f "~S ~S" (car lst) (- (cadr lst))) + (helper (cddr lst))))) (string-join (helper lst) " ")) (define (svg-bezier lst close) (let* ((c0 (car (list-tail lst 3))) - (c123 (list-head lst 3))) + (c123 (list-head lst 3))) (string-append - (if (not close) "M" "L") - (offset->point c0) - "C" (string-join (map offset->point c123) " ") - (if (not close) "" "z")))) + (if (not close) "M" "L") + (offset->point c0) + "C" (string-join (map offset->point c123) " ") + (if (not close) "" "z")))) (define (sqr x) (* x x)) @@ -109,7 +109,7 @@ (define (string->entities string) (apply string-append - (map (lambda (x) (char->entity x)) (string->list string)))) + (map (lambda (x) (char->entity x)) (string->list string)))) (define svg-element-regexp (make-regexp "^(<[a-z]+) ?(.*>)")) @@ -128,24 +128,24 @@ (define (set-attribute attr val) (set! alist (assoc-set! alist attr val))) (let* ((match-1 (regexp-exec pango-description-regexp-comma str)) - (match-2 (regexp-exec pango-description-regexp-nocomma str)) - (match (if match-1 match-1 match-2))) + (match-2 (regexp-exec pango-description-regexp-nocomma str)) + (match (if match-1 match-1 match-2))) (if (regexp-match? match) - (begin - (set-attribute 'font-family (match:prefix match)) - (if (string? (match:substring match 1)) - (set-attribute 'font-weight "bold")) - (if (string? (match:substring match 2)) - (set-attribute 'font-style "italic")) - (if (string? (match:substring match 3)) - (set-attribute 'font-variant "small-caps")) - (set-attribute 'font-size - (/ (string->number (match:substring match 4)) - lily-unit-length)) - (set-attribute 'text-anchor "start") - (set-attribute 'fill "currentColor")) - (ly:warning (_ "cannot decypher Pango description: ~a") str)) + (begin + (set-attribute 'font-family (match:prefix match)) + (if (string? (match:substring match 1)) + (set-attribute 'font-weight "bold")) + (if (string? (match:substring match 2)) + (set-attribute 'font-style "italic")) + (if (string? (match:substring match 3)) + (set-attribute 'font-variant "small-caps")) + (set-attribute 'font-size + (/ (string->number (match:substring match 4)) + lily-unit-length)) + (set-attribute 'text-anchor "start") + (set-attribute 'fill "currentColor")) + (ly:warning (_ "cannot decypher Pango description: ~a") str)) (apply entity 'text expr (reverse! alist)))) @@ -155,21 +155,21 @@ (set! alist (assoc-set! alist attr val))) (if (not (null? rest)) (let* ((dx (car rest)) - (dy (cadr rest)) - (total-x (+ dx next-horiz-adv))) - (if (or (not (zero? total-x)) - (not (zero? dy))) - (let ((x (ly:format "~4f" total-x)) - (y (ly:format "~4f" dy))) - (set-attribute 'transform - (string-append - "translate(" x ", " y ") " - "scale(" scale ", -" scale ")"))) - (set-attribute 'transform - (string-append - "scale(" scale ", -" scale ")")))) + (dy (cadr rest)) + (total-x (+ dx next-horiz-adv))) + (if (or (not (zero? total-x)) + (not (zero? dy))) + (let ((x (ly:format "~4f" total-x)) + (y (ly:format "~4f" dy))) + (set-attribute 'transform + (string-append + "translate(" x ", " y ") " + "scale(" scale ", -" scale ")"))) + (set-attribute 'transform + (string-append + "scale(" scale ", -" scale ")")))) (set-attribute 'transform (string-append - "scale(" scale ", -" scale ")"))) + "scale(" scale ", -" scale ")"))) (set-attribute 'd path) (set-attribute 'fill "currentColor") @@ -201,112 +201,112 @@ ;; (define (glyph-element-regexp name) (make-regexp (string-append "<glyph" - "(([[:space:]]+[-a-z]+=\"[^\"]*\")+)?" - "[[:space:]]+glyph-name=\"(" - name - ")\"" - "(([[:space:]]+[-a-z]+=\"[^\"]*\")+)?" - "([[:space:]]+)?" - "/>"))) + "(([[:space:]]+[-a-z]+=\"[^\"]*\")+)?" + "[[:space:]]+glyph-name=\"(" + name + ")\"" + "(([[:space:]]+[-a-z]+=\"[^\"]*\")+)?" + "([[:space:]]+)?" + "/>"))) (define (extract-glyph all-glyphs name size . rest) (let* ((new-name (regexp-quote name)) - (regexp (regexp-exec (glyph-element-regexp new-name) all-glyphs)) - (glyph (match:substring regexp)) - (unicode-attr (regexp-exec glyph-unicode-value-regexp glyph)) - (unicode-attr-value (match:substring unicode-attr 1)) - (unicode-attr? (regexp-match? unicode-attr)) - (d-attr (regexp-exec glyph-path-regexp glyph)) - (d-attr-value "") - (d-attr? (regexp-match? d-attr)) - ;; TODO: not urgent, but do not hardcode this value - (units-per-em 1000) - (font-scale (ly:format "~4f" (/ size units-per-em))) - (path "")) + (regexp (regexp-exec (glyph-element-regexp new-name) all-glyphs)) + (glyph (match:substring regexp)) + (unicode-attr (regexp-exec glyph-unicode-value-regexp glyph)) + (unicode-attr-value (match:substring unicode-attr 1)) + (unicode-attr? (regexp-match? unicode-attr)) + (d-attr (regexp-exec glyph-path-regexp glyph)) + (d-attr-value "") + (d-attr? (regexp-match? d-attr)) + ;; TODO: not urgent, but do not hardcode this value + (units-per-em 1000) + (font-scale (ly:format "~4f" (/ size units-per-em))) + (path "")) (if (and unicode-attr? (not unicode-attr-value)) - (ly:warning (_ "Glyph must have a unicode value"))) + (ly:warning (_ "Glyph must have a unicode value"))) (if d-attr? (set! d-attr-value (match:substring d-attr 1))) (cond ( - ;; Glyph-strings with path data - (and d-attr? (not (null? rest))) - (begin - (set! path (apply dump-path d-attr-value - font-scale - (list (caddr rest) (cadddr rest)))) - (set! next-horiz-adv (+ next-horiz-adv - (car rest))) - path)) - ;; Glyph-strings without path data ("space") - ((and (not d-attr?) (not (null? rest))) - (begin - (set! next-horiz-adv (+ next-horiz-adv - (car rest))) - "")) - ;; Font smobs with path data - ((and d-attr? (null? rest)) - (set! path (dump-path d-attr-value font-scale)) - path) - ;; Font smobs without path data ("space") - (else - "")))) + ;; Glyph-strings with path data + (and d-attr? (not (null? rest))) + (begin + (set! path (apply dump-path d-attr-value + font-scale + (list (caddr rest) (cadddr rest)))) + (set! next-horiz-adv (+ next-horiz-adv + (car rest))) + path)) + ;; Glyph-strings without path data ("space") + ((and (not d-attr?) (not (null? rest))) + (begin + (set! next-horiz-adv (+ next-horiz-adv + (car rest))) + "")) + ;; Font smobs with path data + ((and d-attr? (null? rest)) + (set! path (dump-path d-attr-value font-scale)) + path) + ;; Font smobs without path data ("space") + (else + "")))) (define (extract-glyph-info all-glyphs glyph size) (let* ((offsets (list-head glyph 4)) - (glyph-name (car (reverse glyph)))) + (glyph-name (car (reverse glyph)))) (apply extract-glyph all-glyphs glyph-name size offsets))) (define (svg-defs svg-font) (let ((start (string-contains svg-font "<defs>")) - (end (string-contains svg-font "</defs>"))) + (end (string-contains svg-font "</defs>"))) (substring svg-font (+ start 7) (- end 1)))) (define (cache-font svg-font size glyph) (let ((all-glyphs (svg-defs (cached-file-contents svg-font)))) (if (list? glyph) - (extract-glyph-info all-glyphs glyph size) - (extract-glyph all-glyphs glyph size)))) + (extract-glyph-info all-glyphs glyph size) + (extract-glyph all-glyphs glyph size)))) (define (music-string-to-path font size glyph) (let* ((name-style (font-name-style font)) - (scaled-size (/ size lily-unit-length)) - (font-file (ly:find-file (string-append name-style ".svg")))) + (scaled-size (/ size lily-unit-length)) + (font-file (ly:find-file (string-append name-style ".svg")))) (if font-file - (cache-font font-file scaled-size glyph) - (ly:warning (_ "cannot find SVG font ~S") font-file)))) + (cache-font font-file scaled-size glyph) + (ly:warning (_ "cannot find SVG font ~S") font-file)))) (define (font-smob-to-path font glyph) (let* ((name-style (font-name-style font)) - (scaled-size (modified-font-metric-font-scaling font)) - (font-file (ly:find-file (string-append name-style ".svg")))) + (scaled-size (modified-font-metric-font-scaling font)) + (font-file (ly:find-file (string-append name-style ".svg")))) (if font-file - (cache-font font-file scaled-size glyph) - (ly:warning (_ "cannot find SVG font ~S") font-file)))) + (cache-font font-file scaled-size glyph) + (ly:warning (_ "cannot find SVG font ~S") font-file)))) (define (woff-font-smob-to-text font expr) (let* ((name-style (font-name-style font)) - (scaled-size (modified-font-metric-font-scaling font)) - (font-file (ly:find-file (string-append name-style ".woff"))) - (charcode (ly:font-glyph-name-to-charcode font expr)) - (char-lookup (format #f "&#~S;" charcode)) - (glyph-by-name (eoc 'altglyph `(glyphname . ,expr))) - (apparently-broken - (comment "FIXME: how to select glyph by name, altglyph is broken?")) - (text (string-regexp-substitute "\n" "" - (string-append glyph-by-name apparently-broken char-lookup)))) - (define alist '()) - (define (set-attribute attr val) - (set! alist (assoc-set! alist attr val))) - (set-attribute 'font-family name-style) - (set-attribute 'font-size scaled-size) - (apply entity 'text text (reverse! alist)))) - + (scaled-size (modified-font-metric-font-scaling font)) + (font-file (ly:find-file (string-append name-style ".woff"))) + (charcode (ly:font-glyph-name-to-charcode font expr)) + (char-lookup (format #f "&#~S;" charcode)) + (glyph-by-name (eoc 'altglyph `(glyphname . ,expr))) + (apparently-broken + (comment "FIXME: how to select glyph by name, altglyph is broken?")) + (text (string-regexp-substitute "\n" "" + (string-append glyph-by-name apparently-broken char-lookup)))) + (define alist '()) + (define (set-attribute attr val) + (set! alist (assoc-set! alist attr val))) + (set-attribute 'font-family name-style) + (set-attribute 'font-size scaled-size) + (apply entity 'text text (reverse! alist)))) + (define font-smob-to-text (if (not (ly:get-option 'svg-woff)) font-smob-to-path woff-font-smob-to-text)) @@ -325,41 +325,41 @@ (define (circle radius thick is-filled) (entity - 'circle "" - '(stroke-linejoin . "round") - '(stroke-linecap . "round") - `(fill . ,(if is-filled "currentColor" "none")) - `(stroke . "currentColor") - `(stroke-width . ,thick) - `(r . ,radius))) + 'circle "" + '(stroke-linejoin . "round") + '(stroke-linecap . "round") + `(fill . ,(if is-filled "currentColor" "none")) + `(stroke . "currentColor") + `(stroke-width . ,thick) + `(r . ,radius))) (define (dashed-line thick on off dx dy phase) (draw-line thick 0 0 dx dy - `(stroke-dasharray . ,(format #f "~a,~a" on off)))) + `(stroke-dasharray . ,(format #f "~a,~a" on off)))) (define (draw-line thick x1 y1 x2 y2 . alist) (apply entity 'line "" - (append - `((stroke-linejoin . "round") - (stroke-linecap . "round") - (stroke-width . ,thick) - (stroke . "currentColor") - (x1 . ,x1) - (y1 . ,(- y1)) - (x2 . ,x2) - (y2 . ,(- y2))) - alist))) + (append + `((stroke-linejoin . "round") + (stroke-linecap . "round") + (stroke-width . ,thick) + (stroke . "currentColor") + (x1 . ,x1) + (y1 . ,(- y1)) + (x2 . ,x2) + (y2 . ,(- y2))) + alist))) (define (ellipse x-radius y-radius thick is-filled) (entity - 'ellipse "" - '(stroke-linejoin . "round") - '(stroke-linecap . "round") - `(fill . ,(if is-filled "currentColor" "none")) - `(stroke . "currentColor") - `(stroke-width . ,thick) - `(rx . ,x-radius) - `(ry . ,y-radius))) + 'ellipse "" + '(stroke-linejoin . "round") + '(stroke-linecap . "round") + `(fill . ,(if is-filled "currentColor" "none")) + `(stroke . "currentColor") + `(stroke-width . ,thick) + `(rx . ,x-radius) + `(ry . ,y-radius))) (define (partial-ellipse x-radius y-radius start-angle end-angle thick connect fill) (define (make-ellipse-radius x-radius y-radius angle) @@ -369,38 +369,38 @@ (* (* x-radius x-radius) (* (sin angle) (sin angle))))))) (let* - ((new-start-angle (* PI-OVER-180 (angle-0-360 start-angle))) - (start-radius (make-ellipse-radius x-radius y-radius new-start-angle)) - (new-end-angle (* PI-OVER-180 (angle-0-360 end-angle))) - (end-radius (make-ellipse-radius x-radius y-radius new-end-angle)) - (epsilon 1.5e-3) - (x-end (- (* end-radius (cos new-end-angle)) - (* start-radius (cos new-start-angle)))) - (y-end (- (* end-radius (sin new-end-angle)) - (* start-radius (sin new-start-angle))))) - (if (and (< (abs x-end) epsilon) (< (abs y-end) epsilon)) - (entity - 'ellipse "" - `(fill . ,(if fill "currentColor" "none")) - `(stroke . "currentColor") - `(stroke-width . ,thick) - '(stroke-linejoin . "round") - '(stroke-linecap . "round") - '(cx . 0) - '(cy . 0) - `(rx . ,x-radius) - `(ry . ,y-radius)) - (entity - 'path "" - `(fill . ,(if fill "currentColor" "none")) - `(stroke . "currentColor") - `(stroke-width . ,thick) - '(stroke-linejoin . "round") - '(stroke-linecap . "round") - (cons - 'd - (string-append - (ly:format + ((new-start-angle (* PI-OVER-180 (angle-0-360 start-angle))) + (start-radius (make-ellipse-radius x-radius y-radius new-start-angle)) + (new-end-angle (* PI-OVER-180 (angle-0-360 end-angle))) + (end-radius (make-ellipse-radius x-radius y-radius new-end-angle)) + (epsilon 1.5e-3) + (x-end (- (* end-radius (cos new-end-angle)) + (* start-radius (cos new-start-angle)))) + (y-end (- (* end-radius (sin new-end-angle)) + (* start-radius (sin new-start-angle))))) + (if (and (< (abs x-end) epsilon) (< (abs y-end) epsilon)) + (entity + 'ellipse "" + `(fill . ,(if fill "currentColor" "none")) + `(stroke . "currentColor") + `(stroke-width . ,thick) + '(stroke-linejoin . "round") + '(stroke-linecap . "round") + '(cx . 0) + '(cy . 0) + `(rx . ,x-radius) + `(ry . ,y-radius)) + (entity + 'path "" + `(fill . ,(if fill "currentColor" "none")) + `(stroke . "currentColor") + `(stroke-width . ,thick) + '(stroke-linejoin . "round") + '(stroke-linecap . "round") + (cons + 'd + (string-append + (ly:format "M~4f ~4fA~4f ~4f 0 ~4f 0 ~4f ~4f" (* start-radius (cos new-start-angle)) (- (* start-radius (sin new-start-angle))) @@ -409,11 +409,11 @@ (if (> 0 (- new-start-angle new-end-angle)) 0 1) (* end-radius (cos new-end-angle)) (- (* end-radius (sin new-end-angle)))) - (if connect - (ly:format "L~4f,~4f" - (* start-radius (cos new-start-angle)) - (- (* start-radius (sin new-start-angle)))) - ""))))))) + (if connect + (ly:format "L~4f,~4f" + (* start-radius (cos new-start-angle)) + (- (* start-radius (sin new-start-angle)))) + ""))))))) (define (embedded-svg string) string) @@ -423,51 +423,51 @@ (if (= 1 (length glyphs)) (set! path (music-string-to-path font size (car glyphs))) (begin - (set! path - (string-append (eo 'g) - (string-join - (map (lambda (x) - (music-string-to-path font size x)) - glyphs) - "\n") - (ec 'g))))) + (set! path + (string-append (eo 'g) + (string-join + (map (lambda (x) + (music-string-to-path font size x)) + glyphs) + "\n") + (ec 'g))))) (set! next-horiz-adv 0.0) path) (define (woff-glyph-string pango-font font-name size cid? w-h-x-y-named-glyphs) (let* ((name-style (font-name-style font-name)) - (family-designsize (regexp-exec (make-regexp "(.*)-([0-9]*)") - font-name)) - (family (if (regexp-match? family-designsize) - (match:substring family-designsize 1) - font-name)) - (design-size (if (regexp-match? family-designsize) - (match:substring family-designsize 2) - #f)) - (scaled-size (/ size lily-unit-length)) - (font (ly:paper-get-font paper `(((font-family . ,family) - ,(if design-size - `(design-size . design-size))))))) + (family-designsize (regexp-exec (make-regexp "(.*)-([0-9]*)") + font-name)) + (family (if (regexp-match? family-designsize) + (match:substring family-designsize 1) + font-name)) + (design-size (if (regexp-match? family-designsize) + (match:substring family-designsize 2) + #f)) + (scaled-size (/ size lily-unit-length)) + (font (ly:paper-get-font paper `(((font-family . ,family) + ,(if design-size + `(design-size . design-size))))))) (define (glyph-spec w h x y g) ; h not used (let* ((charcode (ly:font-glyph-name-to-charcode font g)) - (char-lookup (format #f "&#~S;" charcode)) - (glyph-by-name (eoc 'altglyph `(glyphname . ,g))) - (apparently-broken - (comment "XFIXME: how to select glyph by name, altglyph is broken?"))) - ;; what is W? - (ly:format - "<text~a font-family=\"~a\" font-size=\"~a\">~a</text>" - (if (or (> (abs x) 0.00001) - (> (abs y) 0.00001)) - (ly:format " transform=\"translate(~4f,~4f)\"" x y) - " ") - name-style scaled-size - (string-regexp-substitute - "\n" "" - (string-append glyph-by-name apparently-broken char-lookup))))) + (char-lookup (format #f "&#~S;" charcode)) + (glyph-by-name (eoc 'altglyph `(glyphname . ,g))) + (apparently-broken + (comment "XFIXME: how to select glyph by name, altglyph is broken?"))) + ;; what is W? + (ly:format + "<text~a font-family=\"~a\" font-size=\"~a\">~a</text>" + (if (or (> (abs x) 0.00001) + (> (abs y) 0.00001)) + (ly:format " transform=\"translate(~4f,~4f)\"" x y) + " ") + name-style scaled-size + (string-regexp-substitute + "\n" "" + (string-append glyph-by-name apparently-broken char-lookup))))) (string-join (map (lambda (x) (apply glyph-spec x)) - (reverse w-h-x-y-named-glyphs)) "\n"))) + (reverse w-h-x-y-named-glyphs)) "\n"))) (define glyph-string (if (not (ly:get-option 'svg-woff)) embedded-glyph-string woff-glyph-string)) @@ -484,83 +484,83 @@ (define* (path thick commands #:optional (cap 'round) (join 'round) (fill? #f)) (define (convert-path-exps exps) (if (pair? exps) - (let* - ((head (car exps)) - (rest (cdr exps)) - (arity - (cond ((memq head '(rmoveto rlineto lineto moveto)) 2) - ((memq head '(rcurveto curveto)) 6) - ((eq? head 'closepath) 0) - (else 1))) - (args (take rest arity)) - (svg-head (assoc-get head - '((rmoveto . m) - (rcurveto . c) - (curveto . C) - (moveto . M) - (lineto . L) - (rlineto . l) - (closepath . z)) - ""))) - - (cons (format #f "~a~a" svg-head (number-list->point args)) - (convert-path-exps (drop rest arity)))) - '())) + (let* + ((head (car exps)) + (rest (cdr exps)) + (arity + (cond ((memq head '(rmoveto rlineto lineto moveto)) 2) + ((memq head '(rcurveto curveto)) 6) + ((eq? head 'closepath) 0) + (else 1))) + (args (take rest arity)) + (svg-head (assoc-get head + '((rmoveto . m) + (rcurveto . c) + (curveto . C) + (moveto . M) + (lineto . L) + (rlineto . l) + (closepath . z)) + ""))) + + (cons (format #f "~a~a" svg-head (number-list->point args)) + (convert-path-exps (drop rest arity)))) + '())) (let* ((line-cap-styles '(butt round square)) - (line-join-styles '(miter round bevel)) - (cap-style (if (not (memv cap line-cap-styles)) - (begin - (ly:warning (_ "unknown line-cap-style: ~S") - (symbol->string cap)) - 'round) - cap)) - (join-style (if (not (memv join line-join-styles)) - (begin - (ly:warning (_ "unknown line-join-style: ~S") - (symbol->string join)) - 'round) - join))) + (line-join-styles '(miter round bevel)) + (cap-style (if (not (memv cap line-cap-styles)) + (begin + (ly:warning (_ "unknown line-cap-style: ~S") + (symbol->string cap)) + 'round) + cap)) + (join-style (if (not (memv join line-join-styles)) + (begin + (ly:warning (_ "unknown line-join-style: ~S") + (symbol->string join)) + 'round) + join))) (entity 'path "" - `(stroke-width . ,thick) - `(stroke-linejoin . ,(symbol->string join-style)) - `(stroke-linecap . ,(symbol->string cap-style)) - '(stroke . "currentColor") - `(fill . ,(if fill? "currentColor" "none")) - `(d . ,(apply string-append (convert-path-exps commands)))))) + `(stroke-width . ,thick) + `(stroke-linejoin . ,(symbol->string join-style)) + `(stroke-linecap . ,(symbol->string cap-style)) + '(stroke . "currentColor") + `(fill . ,(if fill? "currentColor" "none")) + `(d . ,(apply string-append (convert-path-exps commands)))))) (define (placebox x y expr) (if (string-null? expr) "" (let* - ((normal-element (regexp-exec svg-element-regexp expr)) - (scaled-element (regexp-exec scaled-element-regexp expr)) - (scaled? (if scaled-element #t #f)) - (match (if scaled? scaled-element normal-element)) - (string1 (match:substring match 1)) - (string2 (match:substring match 2))) - - (if scaled? - (string-append string1 - (ly:format "translate(~4f, ~4f) " x (- y)) - string2 - "\n") - (string-append string1 - (ly:format " transform=\"translate(~4f, ~4f)\" " - x (- y)) - string2 - "\n"))))) + ((normal-element (regexp-exec svg-element-regexp expr)) + (scaled-element (regexp-exec scaled-element-regexp expr)) + (scaled? (if scaled-element #t #f)) + (match (if scaled? scaled-element normal-element)) + (string1 (match:substring match 1)) + (string2 (match:substring match 2))) + + (if scaled? + (string-append string1 + (ly:format "translate(~4f, ~4f) " x (- y)) + string2 + "\n") + (string-append string1 + (ly:format " transform=\"translate(~4f, ~4f)\" " + x (- y)) + string2 + "\n"))))) (define (polygon coords blot-diameter is-filled) (entity - 'polygon "" - '(stroke-linejoin . "round") - '(stroke-linecap . "round") - `(stroke-width . ,blot-diameter) - `(fill . ,(if is-filled "currentColor" "none")) - '(stroke . "currentColor") - `(points . ,(string-join - (map offset->point (ly:list->offsets '() coords)))))) + 'polygon "" + '(stroke-linejoin . "round") + '(stroke-linecap . "round") + `(stroke-width . ,blot-diameter) + `(fill . ,(if is-filled "currentColor" "none")) + '(stroke . "currentColor") + `(points . ,(string-join + (map offset->point (ly:list->offsets '() coords)))))) (define (resetcolor) "</g>\n") @@ -573,34 +573,34 @@ (define (round-filled-box breapth width depth height blot-diameter) (entity - 'rect "" - ;; The stroke will stick out. To use stroke, - ;; the stroke-width must be subtracted from all other dimensions. - ;;'(stroke-linejoin . "round") - ;;'(stroke-linecap . "round") - ;;`(stroke-width . ,blot) - ;;'(stroke . "red") - ;;'(fill . "orange") - - `(x . ,(- breapth)) - `(y . ,(- height)) - `(width . ,(+ breapth width)) - `(height . ,(+ depth height)) - `(ry . ,(/ blot-diameter 2)) - '(fill . "currentColor"))) + 'rect "" + ;; The stroke will stick out. To use stroke, + ;; the stroke-width must be subtracted from all other dimensions. + ;;'(stroke-linejoin . "round") + ;;'(stroke-linecap . "round") + ;;`(stroke-width . ,blot) + ;;'(stroke . "red") + ;;'(fill . "orange") + + `(x . ,(- breapth)) + `(y . ,(- height)) + `(width . ,(+ breapth width)) + `(height . ,(+ depth height)) + `(ry . ,(/ blot-diameter 2)) + '(fill . "currentColor"))) (define (setcolor r g b) (format #f "<g color=\"rgb(~a%, ~a%, ~a%)\">\n" - (* 100 r) (* 100 g) (* 100 b))) + (* 100 r) (* 100 g) (* 100 b))) ;; rotate around given point (define (setrotation ang x y) (ly:format "<g transform=\"rotate(~4f, ~4f, ~4f)\">\n" - (- ang) x (- y))) + (- ang) x (- y))) (define (setscale x y) (ly:format "<g transform=\"scale(~4f, ~4f)\">\n" - x y)) + x y)) (define (text font string) (fontify font (entity 'tspan (string->entities string)))) @@ -609,18 +609,18 @@ (string-append (eo 'a `(xlink:href . ,url)) (eoc 'rect - `(x . ,(car x)) - `(y . ,(car y)) - `(width . ,(- (cdr x) (car x))) - `(height . ,(- (cdr y) (car y))) - '(fill . "none") - '(stroke . "none") - '(stroke-width . "0.0")) + `(x . ,(car x)) + `(y . ,(car y)) + `(width . ,(- (cdr x) (car x))) + `(height . ,(- (cdr y) (car y))) + '(fill . "none") + '(stroke . "none") + '(stroke-width . "0.0")) (ec 'a))) (define (utf-8-string pango-font-description string) (let ((escaped-string (string-regexp-substitute - "<" "<" - (string-regexp-substitute "&" "&" string)))) + "<" "<" + (string-regexp-substitute "&" "&" string)))) (fontify pango-font-description (entity 'tspan escaped-string)))) diff --git a/scm/page.scm b/scm/page.scm index ada4a890f9..bfae0ea2f4 100644 --- a/scm/page.scm +++ b/scm/page.scm @@ -18,25 +18,25 @@ (define-module (scm page) #:export (make-page - page-property - page-set-property! - page-prev - page-printable-height - layout->page-init - page-force - page-penalty - page-configuration - page-lines - page-page-number - page-system-numbers - page-stencil - page-free-height - page? - )) + page-property + page-set-property! + page-prev + page-printable-height + layout->page-init + page-force + page-penalty + page-configuration + page-lines + page-page-number + page-system-numbers + page-stencil + page-free-height + page? + )) (use-modules (lily) - (scm paper-system) - (srfi srfi-1)) + (scm paper-system) + (srfi srfi-1)) (define (annotate? layout) @@ -48,9 +48,9 @@ (define (make-page paper-book . args) (let* ((p (apply ly:make-prob (append - (list 'page (layout->page-init (ly:paper-book-paper paper-book)) - 'paper-book paper-book) - args)))) + (list 'page (layout->page-init (ly:paper-book-paper paper-book)) + 'paper-book paper-book) + args)))) (page-set-property! p 'head-stencil (page-header p)) (page-set-property! p 'foot-stencil (page-footer p)) @@ -84,61 +84,61 @@ (lambda (sys-off) (let* - ((sys (car sys-off)) - (off (cadr sys-off))) + ((sys (car sys-off)) + (off (cadr sys-off))) (if (not (number? (ly:prob-property sys 'Y-offset))) - (ly:prob-set-property! sys 'Y-offset off)))) + (ly:prob-set-property! sys 'Y-offset off)))) (zip (page-property page 'lines) - (page-property page 'configuration)))) + (page-property page 'configuration)))) (define (annotate-top-space first-system layout header-stencil stencil) (let* ((top-margin (ly:output-def-lookup layout 'top-margin)) - (sym (if (paper-system-title? first-system) - 'top-markup-spacing - 'top-system-spacing)) - (spacing-spec (ly:output-def-lookup layout sym)) - (X-offset (ly:prob-property first-system 'X-offset 5)) - (header-extent (ly:stencil-extent header-stencil Y))) + (sym (if (paper-system-title? first-system) + 'top-markup-spacing + 'top-system-spacing)) + (spacing-spec (ly:output-def-lookup layout sym)) + (X-offset (ly:prob-property first-system 'X-offset 5)) + (header-extent (ly:stencil-extent header-stencil Y))) (set! stencil - (ly:stencil-add stencil - (ly:stencil-translate-axis - (annotate-spacing-spec layout - spacing-spec - (- top-margin) - (car header-extent) - #:base-color red) - X-offset X))) + (ly:stencil-add stencil + (ly:stencil-translate-axis + (annotate-spacing-spec layout + spacing-spec + (- top-margin) + (car header-extent) + #:base-color red) + X-offset X))) stencil)) (define (annotate-page layout stencil) (let ((top-margin (ly:output-def-lookup layout 'top-margin)) - (paper-height (ly:output-def-lookup layout 'paper-height)) - (bottom-margin (ly:output-def-lookup layout 'bottom-margin)) - (add-stencil (lambda (y) - (set! stencil - (ly:stencil-add stencil - (ly:stencil-translate-axis y 6 X)))))) + (paper-height (ly:output-def-lookup layout 'paper-height)) + (bottom-margin (ly:output-def-lookup layout 'bottom-margin)) + (add-stencil (lambda (y) + (set! stencil + (ly:stencil-add stencil + (ly:stencil-translate-axis y 6 X)))))) (add-stencil (ly:stencil-translate-axis (annotate-y-interval layout "paper-height" - (cons (- paper-height) 0) - #t) + (cons (- paper-height) 0) + #t) 1 X)) (add-stencil (ly:stencil-translate-axis (annotate-y-interval layout "top-margin" - (cons (- top-margin) 0) - #t) + (cons (- top-margin) 0) + #t) 2 X)) (add-stencil (ly:stencil-translate-axis (annotate-y-interval layout "bottom-margin" - (cons (- paper-height) (- bottom-margin paper-height)) - #t) + (cons (- paper-height) (- bottom-margin paper-height)) + #t) 2 X)) stencil)) @@ -147,16 +147,16 @@ ((paper-book (page-property page 'paper-book)) (layout (ly:paper-book-paper paper-book)) (arrow (annotate-y-interval layout - "space left" - (cons (- 0.0 - (page-property page 'bottom-edge) - (let ((foot (page-property page 'foot-stencil))) - (if (and (ly:stencil? foot) - (not (ly:stencil-empty? foot))) - (car (ly:stencil-extent foot Y)) - 0.0))) - (page-property page 'bottom-system-edge)) - #t))) + "space left" + (cons (- 0.0 + (page-property page 'bottom-edge) + (let ((foot (page-property page 'foot-stencil))) + (if (and (ly:stencil? foot) + (not (ly:stencil-empty? foot))) + (car (ly:stencil-extent foot Y)) + 0.0))) + (page-property page 'bottom-system-edge)) + #t))) (set! arrow (ly:stencil-translate-axis arrow 8 X)) @@ -172,13 +172,13 @@ (is-last-bookpart (page-property page 'is-last-bookpart)) (is-bookpart-last-page (page-property page 'is-bookpart-last-page)) (sym (if (= dir UP) - 'make-header - 'make-footer)) + 'make-header + 'make-footer)) (header-proc (ly:output-def-lookup layout sym))) (if (procedure? header-proc) - (header-proc layout scopes number is-last-bookpart is-bookpart-last-page) - #f))) + (header-proc layout scopes number is-last-bookpart is-bookpart-last-page) + #f))) (define (page-header page) @@ -195,7 +195,7 @@ (left-margin (ly:output-def-lookup layout 'left-margin)) (right-margin (ly:output-def-lookup layout 'right-margin)) (bottom-edge (- paper-height - (ly:output-def-lookup layout 'bottom-margin)) ) + (ly:output-def-lookup layout 'bottom-margin)) ) (top-margin (ly:output-def-lookup layout 'top-margin)) ) @@ -225,114 +225,114 @@ (system-xoffset (ly:output-def-lookup layout 'horizontal-shift 0.0)) (system-separator-markup (ly:output-def-lookup layout 'system-separator-markup)) (system-separator-stencil (if (markup? system-separator-markup) - (interpret-markup layout - (layout-extract-page-properties layout) - system-separator-markup) - #f)) + (interpret-markup layout + (layout-extract-page-properties layout) + system-separator-markup) + #f)) (page-stencil (ly:make-stencil '())) (last-system #f) (last-y 0.0) (add-to-page (lambda (stencil x y) - (set! page-stencil - (ly:stencil-add page-stencil - (ly:stencil-translate stencil - (cons - (+ system-xoffset x) - (- 0 y (prop 'top-margin))) - - ))))) + (set! page-stencil + (ly:stencil-add page-stencil + (ly:stencil-translate stencil + (cons + (+ system-xoffset x) + (- 0 y (prop 'top-margin))) + + ))))) (add-system - (lambda (system) - (let* ((stencil (paper-system-stencil system)) - (y (ly:prob-property system 'Y-offset 0)) - (is-title (paper-system-title? - system))) - (add-to-page stencil - (ly:prob-property system 'X-offset 0.0) - y) - (if (and (ly:stencil? system-separator-stencil) - last-system - (not (paper-system-title? system)) - (not (paper-system-title? last-system))) - (add-to-page - system-separator-stencil - 0 - (average (- last-y - (car (paper-system-staff-extents last-system))) - (- y - (cdr (paper-system-staff-extents system)))))) - (set! last-system system) - (set! last-y y)))) + (lambda (system) + (let* ((stencil (paper-system-stencil system)) + (y (ly:prob-property system 'Y-offset 0)) + (is-title (paper-system-title? + system))) + (add-to-page stencil + (ly:prob-property system 'X-offset 0.0) + y) + (if (and (ly:stencil? system-separator-stencil) + last-system + (not (paper-system-title? system)) + (not (paper-system-title? last-system))) + (add-to-page + system-separator-stencil + 0 + (average (- last-y + (car (paper-system-staff-extents last-system))) + (- y + (cdr (paper-system-staff-extents system)))))) + (set! last-system system) + (set! last-y y)))) (head (prop 'head-stencil)) (foot (prop 'foot-stencil)) ) (if (and - (ly:stencil? head) - (not (ly:stencil-empty? head))) - (begin - ;; Ensure that the top of the header just touches the top margin. - (set! head (ly:stencil-translate-axis head - (- 0 (cdr (ly:stencil-extent head Y)) (prop 'top-margin)) Y)) - (set! page-stencil (ly:stencil-add page-stencil head)))) + (ly:stencil? head) + (not (ly:stencil-empty? head))) + (begin + ;; Ensure that the top of the header just touches the top margin. + (set! head (ly:stencil-translate-axis head + (- 0 (cdr (ly:stencil-extent head Y)) (prop 'top-margin)) Y)) + (set! page-stencil (ly:stencil-add page-stencil head)))) (if (and - (annotate? layout) - (pair? lines)) + (annotate? layout) + (pair? lines)) - (begin - (set! page-stencil (annotate-top-space (car lines) layout head page-stencil)) + (begin + (set! page-stencil (annotate-top-space (car lines) layout head page-stencil)) - (for-each (lambda (sys next-sys) - (paper-system-annotate sys next-sys layout)) - lines - (append (cdr lines) (list #f))) - (paper-system-annotate-last (car (last-pair lines)) layout))) + (for-each (lambda (sys next-sys) + (paper-system-annotate sys next-sys layout)) + lines + (append (cdr lines) (list #f))) + (paper-system-annotate-last (car (last-pair lines)) layout))) (map add-system lines) (ly:prob-set-property! page 'bottom-system-edge - (car (ly:stencil-extent page-stencil Y))) + (car (ly:stencil-extent page-stencil Y))) (ly:prob-set-property! page 'space-left - (+ (prop 'bottom-edge) - (prop 'bottom-system-edge) - (if (and (ly:stencil? foot) - (not (ly:stencil-empty? foot))) - (car (ly:stencil-extent foot Y)) - 0.0))) + (+ (prop 'bottom-edge) + (prop 'bottom-system-edge) + (if (and (ly:stencil? foot) + (not (ly:stencil-empty? foot))) + (car (ly:stencil-extent foot Y)) + 0.0))) (if (annotate? layout) - (set! page-stencil - (ly:stencil-add page-stencil - (annotate-space-left page)))) + (set! page-stencil + (ly:stencil-add page-stencil + (annotate-space-left page)))) (if (and (ly:stencil? foot) - (not (ly:stencil-empty? foot))) - (set! page-stencil - (ly:stencil-add - page-stencil - (ly:stencil-translate - foot - (cons 0 - (+ (- (prop 'bottom-edge)) - (- (car (ly:stencil-extent foot Y))))))))) + (not (ly:stencil-empty? foot))) + (set! page-stencil + (ly:stencil-add + page-stencil + (ly:stencil-translate + foot + (cons 0 + (+ (- (prop 'bottom-edge)) + (- (car (ly:stencil-extent foot Y))))))))) (if (ly:output-def-lookup layout 'two-sided #f) - (set! page-stencil - (ly:stencil-translate page-stencil - (cons (prop (if (even? number) - 'left-margin - 'right-margin)) - 0))) - (set! page-stencil - (ly:stencil-translate page-stencil (cons (prop 'left-margin) 0)))) + (set! page-stencil + (ly:stencil-translate page-stencil + (cons (prop (if (even? number) + 'left-margin + 'right-margin)) + 0))) + (set! page-stencil + (ly:stencil-translate page-stencil (cons (prop 'left-margin) 0)))) ;; annotation. (if (annotate? layout) - (set! page-stencil (annotate-page layout page-stencil))) + (set! page-stencil (annotate-page layout page-stencil))) page-stencil)) @@ -352,18 +352,18 @@ ((paper-book (page-property page 'paper-book)) (layout (ly:paper-book-paper paper-book)) (h (- (ly:output-def-lookup layout 'paper-height) - (ly:output-def-lookup layout 'top-margin) - (ly:output-def-lookup layout 'bottom-margin))) + (ly:output-def-lookup layout 'top-margin) + (ly:output-def-lookup layout 'bottom-margin))) (head (page-property page 'head-stencil)) (foot (page-property page 'foot-stencil)) (available - (- h (if (ly:stencil? head) - (interval-length (ly:stencil-extent head Y)) - 0) - (if (ly:stencil? foot) - (interval-length (ly:stencil-extent foot Y)) - 0)))) + (- h (if (ly:stencil? head) + (interval-length (ly:stencil-extent head Y)) + 0) + (if (ly:stencil? foot) + (interval-length (ly:stencil-extent foot Y)) + 0)))) ;; (display (list "\n available" available head foot)) available)) diff --git a/scm/paper-system.scm b/scm/paper-system.scm index 8269c77e18..e75440b968 100644 --- a/scm/paper-system.scm +++ b/scm/paper-system.scm @@ -18,12 +18,12 @@ (define-module (scm paper-system)) (use-modules (lily) - (srfi srfi-1) - (ice-9 optargs)) + (srfi srfi-1) + (ice-9 optargs)) (define-public (paper-system-title? system) (equal? #t (ly:prob-property system 'is-title) - )) + )) (define (system-stencil system-grob main-stencil) (let* ((padding (ly:grob-property system-grob 'in-note-padding #f)) @@ -31,8 +31,8 @@ (in-notes (if in-notes in-notes empty-stencil)) (direction (if padding (ly:grob-property system-grob 'in-note-direction) UP))) (if padding - (ly:stencil-combine-at-edge main-stencil Y direction in-notes padding) - main-stencil))) + (ly:stencil-combine-at-edge main-stencil Y direction in-notes padding) + main-stencil))) (define-public (paper-system-stencil system) (let ((main-stencil (ly:prob-property system 'stencil)) @@ -46,8 +46,8 @@ ((g (paper-system-system-grob system))) (if (ly:grob? g) - (ly:grob-layout g) - #f))) + (ly:grob-layout g) + #f))) (define-public (paper-system-system-grob paper-system) (ly:prob-property paper-system 'system-grob)) @@ -64,199 +64,199 @@ (y-extent (paper-system-extent system Y)) (x-extent (paper-system-extent system X)) (stencil (ly:prob-property system 'stencil)) - + (arrow (if (number? bottomspace) - (annotate-y-interval layout - "bottom-space" - (cons (- (car y-extent) bottomspace) - (car y-extent)) - #t) - #f))) - + (annotate-y-interval layout + "bottom-space" + (cons (- (car y-extent) bottomspace) + (car y-extent)) + #t) + #f))) + (if arrow - (set! stencil - (ly:stencil-add stencil arrow))) + (set! stencil + (ly:stencil-add stencil arrow))) (set! (ly:prob-property system 'stencil) - stencil) - )) + stencil) + )) ;; Y-ext and next-Y-ext are either skyline-pairs or extents (define*-public (annotate-padding system-Y system-X Y-ext X-ext - next-system-Y next-system-X next-Y-ext next-X-ext - layout horizon-padding padding #:key (base-color blue)) + next-system-Y next-system-X next-Y-ext next-X-ext + layout horizon-padding padding #:key (base-color blue)) (let* ((eps 0.001) - (skyline (and (ly:skyline-pair? Y-ext) - (ly:skyline-pair::skyline Y-ext DOWN))) - (next-skyline (and (ly:skyline-pair? next-Y-ext) - (ly:skyline-pair::skyline next-Y-ext UP))) - (annotation-X (cond - ((and skyline next-skyline) - (- - (ly:skyline::get-touching-point skyline next-skyline horizon-padding) - horizon-padding)) - (skyline - (ly:skyline::get-max-height-position skyline)) - (next-skyline - (ly:skyline::get-max-height-position next-skyline)) - (else - (max (cdr X-ext) - (cdr next-X-ext))))) - (annotation-Y (if skyline - (ly:skyline::get-height skyline annotation-X) - (car Y-ext))) - (next-annotation-Y (if next-skyline - (- (+ (ly:skyline::get-height next-skyline - (- (+ annotation-X system-X) - next-system-X)) - next-system-Y) - system-Y) - (cdr next-Y-ext))) - (padding-blocks (>= next-annotation-Y (- annotation-Y padding eps))) - (contrast-color (append (cdr base-color) (list (car base-color)))) - (color (if padding-blocks contrast-color base-color)) - (annotation (ly:stencil-translate-axis - (annotate-y-interval - layout - "padding" - `(,(- annotation-Y padding). ,annotation-Y) - #t - #:color color) - annotation-X X))) + (skyline (and (ly:skyline-pair? Y-ext) + (ly:skyline-pair::skyline Y-ext DOWN))) + (next-skyline (and (ly:skyline-pair? next-Y-ext) + (ly:skyline-pair::skyline next-Y-ext UP))) + (annotation-X (cond + ((and skyline next-skyline) + (- + (ly:skyline::get-touching-point skyline next-skyline horizon-padding) + horizon-padding)) + (skyline + (ly:skyline::get-max-height-position skyline)) + (next-skyline + (ly:skyline::get-max-height-position next-skyline)) + (else + (max (cdr X-ext) + (cdr next-X-ext))))) + (annotation-Y (if skyline + (ly:skyline::get-height skyline annotation-X) + (car Y-ext))) + (next-annotation-Y (if next-skyline + (- (+ (ly:skyline::get-height next-skyline + (- (+ annotation-X system-X) + next-system-X)) + next-system-Y) + system-Y) + (cdr next-Y-ext))) + (padding-blocks (>= next-annotation-Y (- annotation-Y padding eps))) + (contrast-color (append (cdr base-color) (list (car base-color)))) + (color (if padding-blocks contrast-color base-color)) + (annotation (ly:stencil-translate-axis + (annotate-y-interval + layout + "padding" + `(,(- annotation-Y padding). ,annotation-Y) + #t + #:color color) + annotation-X X))) (if (> padding 0.0) - annotation - empty-stencil))) + annotation + empty-stencil))) + - (define-public (paper-system-annotate system next-system layout) "Add arrows and texts to indicate which lengths are set." (let* ((grob (ly:prob-property system 'system-grob)) - (paper-height (ly:output-def-lookup layout 'paper-height)) - (bottom-margin (ly:output-def-lookup layout 'bottom-margin)) - (top-margin (ly:output-def-lookup layout 'top-margin)) - (spaceable-staves (if (ly:grob? grob) (ly:system::get-spaceable-staves grob) '())) - (all-staves (if (ly:grob? grob) (ly:system::get-staves grob) '())) - (spaceable-staff-annotate - (lambda (before-staff after-staff) - (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y)) - (after-Y (ly:grob-relative-coordinate after-staff grob Y))) - (annotate-spacing-spec - layout - (ly:get-spacing-spec before-staff after-staff) - before-Y - after-Y)))) + (paper-height (ly:output-def-lookup layout 'paper-height)) + (bottom-margin (ly:output-def-lookup layout 'bottom-margin)) + (top-margin (ly:output-def-lookup layout 'top-margin)) + (spaceable-staves (if (ly:grob? grob) (ly:system::get-spaceable-staves grob) '())) + (all-staves (if (ly:grob? grob) (ly:system::get-staves grob) '())) + (spaceable-staff-annotate + (lambda (before-staff after-staff) + (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y)) + (after-Y (ly:grob-relative-coordinate after-staff grob Y))) + (annotate-spacing-spec + layout + (ly:get-spacing-spec before-staff after-staff) + before-Y + after-Y)))) - (staff-padding-annotate - (lambda (before-staff after-staff) - (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y)) - (before-X (ly:grob-relative-coordinate before-staff grob X)) - (before-X-ext (ly:grob-extent before-staff before-staff X)) - (after-Y (ly:grob-relative-coordinate after-staff grob Y)) - (after-X (ly:grob-relative-coordinate after-staff grob X)) - (after-X-ext (ly:grob-extent after-staff after-staff X)) - (skylines (ly:grob-property before-staff 'vertical-skylines)) - (after-skylines (ly:grob-property after-staff 'vertical-skylines)) - (padding (assoc-get 'padding - (ly:get-spacing-spec before-staff after-staff) - 0.0)) - (horizon-padding (ly:grob-property before-staff - 'skyline-horizontal-padding - 0.0))) - (ly:stencil-translate - (annotate-padding - before-Y before-X skylines before-X-ext - after-Y after-X after-skylines after-X-ext - layout horizon-padding padding) - (cons before-X before-Y))))) + (staff-padding-annotate + (lambda (before-staff after-staff) + (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y)) + (before-X (ly:grob-relative-coordinate before-staff grob X)) + (before-X-ext (ly:grob-extent before-staff before-staff X)) + (after-Y (ly:grob-relative-coordinate after-staff grob Y)) + (after-X (ly:grob-relative-coordinate after-staff grob X)) + (after-X-ext (ly:grob-extent after-staff after-staff X)) + (skylines (ly:grob-property before-staff 'vertical-skylines)) + (after-skylines (ly:grob-property after-staff 'vertical-skylines)) + (padding (assoc-get 'padding + (ly:get-spacing-spec before-staff after-staff) + 0.0)) + (horizon-padding (ly:grob-property before-staff + 'skyline-horizontal-padding + 0.0))) + (ly:stencil-translate + (annotate-padding + before-Y before-X skylines before-X-ext + after-Y after-X after-skylines after-X-ext + layout horizon-padding padding) + (cons before-X before-Y))))) - (staff-annotations (if (< 1 (length spaceable-staves)) - (map spaceable-staff-annotate - (drop-right spaceable-staves 1) - (drop spaceable-staves 1)) - '())) - (staff-padding-annotations (if (< 1 (length all-staves)) - (map staff-padding-annotate - (drop-right all-staves 1) - (drop all-staves 1)) - '())) - (estimate-extent (if (ly:grob? grob) - (annotate-y-interval layout - "extent-estimate" - (ly:grob-property grob 'pure-Y-extent) - #f) - #f)) + (staff-annotations (if (< 1 (length spaceable-staves)) + (map spaceable-staff-annotate + (drop-right spaceable-staves 1) + (drop spaceable-staves 1)) + '())) + (staff-padding-annotations (if (< 1 (length all-staves)) + (map staff-padding-annotate + (drop-right all-staves 1) + (drop all-staves 1)) + '())) + (estimate-extent (if (ly:grob? grob) + (annotate-y-interval layout + "extent-estimate" + (ly:grob-property grob 'pure-Y-extent) + #f) + #f)) - (spacing-spec (cond ((and next-system - (paper-system-title? system) - (paper-system-title? next-system)) - (ly:output-def-lookup layout 'markup-markup-spacing)) - ((paper-system-title? system) - (ly:output-def-lookup layout 'markup-system-spacing)) - ((and next-system - (paper-system-title? next-system)) - (ly:output-def-lookup layout 'score-markup-spacing)) - ((not next-system) - (ly:output-def-lookup layout 'last-bottom-spacing)) - ((ly:prob-property system 'last-in-score #f) - (ly:output-def-lookup layout 'score-system-spacing)) - (else - (ly:output-def-lookup layout 'system-system-spacing)))) - (last-staff-Y (car (paper-system-staff-extents system))) - (system-Y (ly:prob-property system 'Y-offset 0.0)) - (system-X (ly:prob-property system 'X-offset 0.0)) - (next-system-Y (and next-system - (ly:prob-property next-system 'Y-offset 0.0))) - (next-system-X (and next-system - (ly:prob-property next-system 'X-offset 0.0))) - (first-staff-next-system-Y (if next-system - (- (+ (cdr (paper-system-staff-extents next-system)) - system-Y) - next-system-Y) - (+ system-Y top-margin bottom-margin (- paper-height)))) + (spacing-spec (cond ((and next-system + (paper-system-title? system) + (paper-system-title? next-system)) + (ly:output-def-lookup layout 'markup-markup-spacing)) + ((paper-system-title? system) + (ly:output-def-lookup layout 'markup-system-spacing)) + ((and next-system + (paper-system-title? next-system)) + (ly:output-def-lookup layout 'score-markup-spacing)) + ((not next-system) + (ly:output-def-lookup layout 'last-bottom-spacing)) + ((ly:prob-property system 'last-in-score #f) + (ly:output-def-lookup layout 'score-system-spacing)) + (else + (ly:output-def-lookup layout 'system-system-spacing)))) + (last-staff-Y (car (paper-system-staff-extents system))) + (system-Y (ly:prob-property system 'Y-offset 0.0)) + (system-X (ly:prob-property system 'X-offset 0.0)) + (next-system-Y (and next-system + (ly:prob-property next-system 'Y-offset 0.0))) + (next-system-X (and next-system + (ly:prob-property next-system 'X-offset 0.0))) + (first-staff-next-system-Y (if next-system + (- (+ (cdr (paper-system-staff-extents next-system)) + system-Y) + next-system-Y) + (+ system-Y top-margin bottom-margin (- paper-height)))) - (skyline (or - (ly:prob-property system 'vertical-skylines #f) - (paper-system-extent system Y))) - (next-skyline (and next-system - (or - (ly:prob-property next-system 'vertical-skylines #f) - (paper-system-extent next-system Y)))) - (horizon-padding (and - (ly:grob? grob) - (ly:grob-property grob 'skyline-horizontal-padding 0))) - (padding-annotation (if (skyline-pair-and-non-empty? next-system) - (annotate-padding - (- system-Y) system-X skyline (paper-system-extent system X) - (- next-system-Y) next-system-X next-skyline (paper-system-extent next-system X) - layout - horizon-padding - (assoc-get 'padding spacing-spec 0.0) - #:base-color blue) - empty-stencil)) + (skyline (or + (ly:prob-property system 'vertical-skylines #f) + (paper-system-extent system Y))) + (next-skyline (and next-system + (or + (ly:prob-property next-system 'vertical-skylines #f) + (paper-system-extent next-system Y)))) + (horizon-padding (and + (ly:grob? grob) + (ly:grob-property grob 'skyline-horizontal-padding 0))) + (padding-annotation (if (skyline-pair-and-non-empty? next-system) + (annotate-padding + (- system-Y) system-X skyline (paper-system-extent system X) + (- next-system-Y) next-system-X next-skyline (paper-system-extent next-system X) + layout + horizon-padding + (assoc-get 'padding spacing-spec 0.0) + #:base-color blue) + empty-stencil)) - (system-annotation (annotate-spacing-spec - layout spacing-spec - last-staff-Y - first-staff-next-system-Y)) - (annotations (ly:stencil-add - padding-annotation - (stack-stencils Y DOWN 0.0 staff-padding-annotations) - (stack-stencils Y DOWN 0.0 (append staff-annotations (list system-annotation)))))) + (system-annotation (annotate-spacing-spec + layout spacing-spec + last-staff-Y + first-staff-next-system-Y)) + (annotations (ly:stencil-add + padding-annotation + (stack-stencils Y DOWN 0.0 staff-padding-annotations) + (stack-stencils Y DOWN 0.0 (append staff-annotations (list system-annotation)))))) - (if estimate-extent - (set! annotations - (stack-stencils X RIGHT 5.5 - (list annotations - estimate-extent)))) + (if estimate-extent + (set! annotations + (stack-stencils X RIGHT 5.5 + (list annotations + estimate-extent)))) - (if (not (null? annotations)) - (set! (ly:prob-property system 'stencil) - (ly:stencil-add - (ly:prob-property system 'stencil) - (ly:make-stencil - (ly:stencil-expr annotations) - (ly:stencil-extent empty-stencil X) - (ly:stencil-extent empty-stencil Y))))) - (ly:prob-property system 'stencil))) + (if (not (null? annotations)) + (set! (ly:prob-property system 'stencil) + (ly:stencil-add + (ly:prob-property system 'stencil) + (ly:make-stencil + (ly:stencil-expr annotations) + (ly:stencil-extent empty-stencil X) + (ly:stencil-extent empty-stencil Y))))) + (ly:prob-property system 'stencil))) diff --git a/scm/paper.scm b/scm/paper.scm index 4cd029b75e..5e788af312 100644 --- a/scm/paper.scm +++ b/scm/paper.scm @@ -15,38 +15,38 @@ ;;;; You should have received a copy of the GNU General Public License ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>. -; for define-safe-public when byte-compiling using Guile V2 + ; for define-safe-public when byte-compiling using Guile V2 (use-modules (scm safe-utility-defs)) (define-public (set-paper-dimension-variables mod) (module-define! mod 'dimension-variables - '(blot-diameter - bottom-margin - cm - footnote-footer-padding - footnote-padding - horizontal-shift - in - indent - inner-margin - inner-margin-default-scaled - ledger-line-thickness - left-margin + '(blot-diameter + bottom-margin + cm + footnote-footer-padding + footnote-padding + horizontal-shift + in + indent + inner-margin + inner-margin-default-scaled + ledger-line-thickness + left-margin left-margin-default-scaled - line-thickness - line-width - mm - outer-margin - outer-margin-default-scaled - paper-height - paper-width - pt - right-margin + line-thickness + line-width + mm + outer-margin + outer-margin-default-scaled + paper-height + paper-width + pt + right-margin right-margin-default-scaled - short-indent - staff-height - staff-space - top-margin))) + short-indent + staff-height + staff-space + top-margin))) (define (calc-line-thickness staff-space pt) ;; linear interpolation. @@ -70,7 +70,7 @@ (ss (/ staff-height 4)) (factor (/ staff-height (* 20 pt))) (setm! (lambda (sym val) - (module-define! module sym val)))) + (module-define! module sym val)))) ;; Synchronized with the `text-font-size' ;; binding in add-pango-fonts (see font.scm). @@ -104,23 +104,23 @@ (define-safe-public (set-global-staff-size sz) "Set the default staff size, where SZ is thought to be in PT." (let* ((current-mod (current-module)) - (parser (eval 'parser current-mod)) - (pap (ly:parser-lookup parser '$defaultpaper)) - (in-layout? (or (module-defined? current-mod 'is-paper) - (module-defined? current-mod 'is-layout))) - - ;; maybe not necessary. - ;; but let's be paranoid. Maybe someone still refers to the - ;; old one. - (new-paper (ly:output-def-clone pap)) + (parser (eval 'parser current-mod)) + (pap (ly:parser-lookup parser '$defaultpaper)) + (in-layout? (or (module-defined? current-mod 'is-paper) + (module-defined? current-mod 'is-layout))) + + ;; maybe not necessary. + ;; but let's be paranoid. Maybe someone still refers to the + ;; old one. + (new-paper (ly:output-def-clone pap)) - (new-scope (ly:output-def-scope new-paper))) + (new-scope (ly:output-def-scope new-paper))) (if in-layout? - (ly:warning (_ "set-global-staff-size: not in toplevel scope"))) + (ly:warning (_ "set-global-staff-size: not in toplevel scope"))) (layout-set-absolute-staff-size-in-module new-scope - (* sz (eval 'pt new-scope))) + (* sz (eval 'pt new-scope))) (module-define! current-mod '$defaultpaper new-paper))) (define-public paper-alist @@ -245,17 +245,17 @@ where @var{landscape?} specifies whether the dimensions should be swapped unless explicitly overriden in the name." (let* ((swapped? - (cond ((string-suffix? "landscape" name) - (set! name - (string-trim-right (string-drop-right name 9))) - #t) - ((string-suffix? "portrait" name) - (set! name - (string-trim-right (string-drop-right name 8))) - #f) - (else landscape?))) - (is-paper? (module-defined? module 'is-paper)) - (entry (and is-paper? + (cond ((string-suffix? "landscape" name) + (set! name + (string-trim-right (string-drop-right name 9))) + #t) + ((string-suffix? "portrait" name) + (set! name + (string-trim-right (string-drop-right name 8))) + #f) + (else landscape?))) + (is-paper? (module-defined? module 'is-paper)) + (entry (and is-paper? (eval-carefully (assoc-get name paper-alist) module #f)))) @@ -275,21 +275,21 @@ unless explicitly overriden in the name." ;; Output_def::normalize () needs to know ;; whether the user set the value or not. (scaleable-values '(("left-margin" #f . #t) - ("right-margin" #f . #t) - ("inner-margin" #f . #t) - ("outer-margin" #f . #t) - ("binding-offset" #f . #f) - ("top-margin" #t . #f) - ("bottom-margin" #t . #f) - ("indent" #f . #f) - ("short-indent" #f . #f))) + ("right-margin" #f . #t) + ("inner-margin" #f . #t) + ("outer-margin" #f . #t) + ("binding-offset" #f . #f) + ("top-margin" #t . #f) + ("bottom-margin" #t . #f) + ("indent" #f . #f) + ("short-indent" #f . #f))) (scaled-values - (map + (map (lambda (entry) (let ((entry-symbol - (string->symbol - (string-append (car entry) "-default"))) - (vertical? (cadr entry))) + (string->symbol + (string-append (car entry) "-default"))) + (vertical? (cadr entry))) (cons (if (cddr entry) (string-append (car entry) "-default-scaled") (car entry)) @@ -308,8 +308,8 @@ unless explicitly overriden in the name." (for-each (lambda (value) (let ((value-symbol (string->symbol (car value))) - (number (cdr value))) - (module-define! m value-symbol number))) + (number (cdr value))) + (module-define! m value-symbol number))) scaled-values))) (define (internal-set-paper-size module name landscape?) @@ -320,10 +320,10 @@ unless explicitly overriden in the name." (ly:warning (_ "This is not a \\layout {} object, ~S") module)) (entry (set-paper-dimensions module (car entry) (cdr entry) landscape?) - + (module-define! module 'papersizename name) (module-define! module 'landscape - (if landscape? #t #f))) + (if landscape? #t #f))) (else (ly:warning (_ "Unknown paper size: ~a") name))))) @@ -340,7 +340,7 @@ unless explicitly overriden in the name." (define-public (set-paper-size name . rest) (if (module-defined? (current-module) 'is-paper) (internal-set-paper-size (current-module) name - (memq 'landscape rest)) + (memq 'landscape rest)) ;;; TODO: should raise (generic) exception with throw, and catch ;;; that in parse-scm.cc @@ -349,19 +349,19 @@ unless explicitly overriden in the name." (define-public (scale-layout paper scale) "Return a clone of the paper, scaled by the given scale factor." (let* ((new-paper (ly:output-def-clone paper)) - (dim-vars (ly:output-def-lookup paper 'dimension-variables)) - (old-scope (ly:output-def-scope paper)) - (scope (ly:output-def-scope new-paper))) + (dim-vars (ly:output-def-lookup paper 'dimension-variables)) + (old-scope (ly:output-def-scope paper)) + (scope (ly:output-def-scope new-paper))) (for-each (lambda (v) (let* ((var (module-variable old-scope v)) - (val (if (variable? var) (variable-ref var) #f))) + (val (if (variable? var) (variable-ref var) #f))) - (if (number? val) - (module-define! scope v (/ val scale)) - ;; Cannot warn for non-numbers, eg. for paper-width, paper-height. - ))) + (if (number? val) + (module-define! scope v (/ val scale)) + ;; Cannot warn for non-numbers, eg. for paper-width, paper-height. + ))) dim-vars) ;; Mark the clone. (ly:output-def-set-variable! new-paper 'cloned #t) diff --git a/scm/parser-clef.scm b/scm/parser-clef.scm index 5dd09a059d..719cc4ce50 100644 --- a/scm/parser-clef.scm +++ b/scm/parser-clef.scm @@ -122,23 +122,23 @@ (map (lambda (x) (set! (ly:music-property m (car x)) (cdr x))) props) m)) (let ((e '()) - (c0 0) - (oct 0) - (style 'default) - (match (string-match "^(.*)([_^])([^0-9a-zA-Z]*)([1-9][0-9]*)([^0-9a-zA-Z]*)$" clef-name))) + (c0 0) + (oct 0) + (style 'default) + (match (string-match "^(.*)([_^])([^0-9a-zA-Z]*)([1-9][0-9]*)([^0-9a-zA-Z]*)$" clef-name))) (if match - (begin - (set! clef-name (match:substring match 1)) - (set! oct - (* (if (equal? (match:substring match 2) "^") -1 1) - (- (string->number (match:substring match 4)) 1))) + (begin + (set! clef-name (match:substring match 1)) + (set! oct + (* (if (equal? (match:substring match 2) "^") -1 1) + (- (string->number (match:substring match 4)) 1))) (set! style (cond ((equal? (match:substring match 3) "(") 'parenthesized) ((equal? (match:substring match 3) "[") 'bracketed) (else style))))) (set! e (assoc-get clef-name supported-clefs)) (if e - (let* ((prop-list `(((symbol . clefGlyph) (value . ,(car e))) + (let* ((prop-list `(((symbol . clefGlyph) (value . ,(car e))) ((symbol . middleCClefPosition) (value . ,(+ oct (cadr e) @@ -150,22 +150,22 @@ (prop-list (if (eq? style 'default) prop-list (append - prop-list - `(((symbol . clefTranspositionStyle) - (value . ,style)))))) - (musics (map make-prop-set prop-list)) - (recalc-mid-C (make-music 'ApplyContext)) - (seq (make-music 'SequentialMusic - 'elements (append musics (list recalc-mid-C)))) - (csp (make-music 'ContextSpeccedMusic))) - (set! (ly:music-property recalc-mid-C 'procedure) ly:set-middle-C!) - (context-spec-music seq 'Staff)) - (begin - (ly:warning (_ "unknown clef type `~a'") clef-name) - (ly:warning (_ "supported clefs: ~a") - (string-join - (sort (map car supported-clefs) string<?))) - (make-music 'Music))))) + prop-list + `(((symbol . clefTranspositionStyle) + (value . ,style)))))) + (musics (map make-prop-set prop-list)) + (recalc-mid-C (make-music 'ApplyContext)) + (seq (make-music 'SequentialMusic + 'elements (append musics (list recalc-mid-C)))) + (csp (make-music 'ContextSpeccedMusic))) + (set! (ly:music-property recalc-mid-C 'procedure) ly:set-middle-C!) + (context-spec-music seq 'Staff)) + (begin + (ly:warning (_ "unknown clef type `~a'") clef-name) + (ly:warning (_ "supported clefs: ~a") + (string-join + (sort (map car supported-clefs) string<?))) + (make-music 'Music))))) (define-public (make-cue-clef-set clef-name) "Generate the clef setting commands for a cue clef with name diff --git a/scm/parser-ly-from-scheme.scm b/scm/parser-ly-from-scheme.scm index 23978608a2..7d72a25e87 100644 --- a/scm/parser-ly-from-scheme.scm +++ b/scm/parser-ly-from-scheme.scm @@ -21,58 +21,58 @@ from @var{port} and return the corresponding Scheme music expression. @samp{$} and @samp{#} introduce immediate and normal Scheme forms." (let* ((closures '()) - (filename (port-filename port)) - (line (port-line port)) - (lily-string (call-with-output-string - (lambda (out) - (let ((copycat - (make-soft-port - (vector #f #f #f - (lambda () - (let ((x (read-char port))) - (write-char x out) - x)) #f) - "r"))) - (set-port-filename! copycat filename) - (do ((c (read-char port) (read-char port))) - ((and (char=? c #\#) - (char=? (peek-char port) #\})) - ;; we stop when #} is encountered - (read-char port)) - (write-char c out) - ;; a #scheme or $scheme expression - (if (or (char=? c #\#) (char=? c #\$)) - (let* ((p (ftell out)) - (expr - (begin - (set-port-line! copycat - (port-line port)) - (set-port-column! copycat - (port-column port)) - (if (char=? (peek-char port) #\@) - (read-char copycat)) - (read copycat)))) - ;; kill unused lookahead, it has been - ;; written out already - (drain-input copycat) - ;; only put symbols and non-quote - ;; lists into closures -- constants - ;; don't need lexical environments - ;; for evaluation. - (if (or (symbol? expr) - (and (pair? expr) - (not (eq? 'quote (car expr))))) - (set! closures - (cons `(cons ,p (lambda () ,expr)) - closures))))))))))) + (filename (port-filename port)) + (line (port-line port)) + (lily-string (call-with-output-string + (lambda (out) + (let ((copycat + (make-soft-port + (vector #f #f #f + (lambda () + (let ((x (read-char port))) + (write-char x out) + x)) #f) + "r"))) + (set-port-filename! copycat filename) + (do ((c (read-char port) (read-char port))) + ((and (char=? c #\#) + (char=? (peek-char port) #\})) + ;; we stop when #} is encountered + (read-char port)) + (write-char c out) + ;; a #scheme or $scheme expression + (if (or (char=? c #\#) (char=? c #\$)) + (let* ((p (ftell out)) + (expr + (begin + (set-port-line! copycat + (port-line port)) + (set-port-column! copycat + (port-column port)) + (if (char=? (peek-char port) #\@) + (read-char copycat)) + (read copycat)))) + ;; kill unused lookahead, it has been + ;; written out already + (drain-input copycat) + ;; only put symbols and non-quote + ;; lists into closures -- constants + ;; don't need lexical environments + ;; for evaluation. + (if (or (symbol? expr) + (and (pair? expr) + (not (eq? 'quote (car expr))))) + (set! closures + (cons `(cons ,p (lambda () ,expr)) + closures))))))))))) (define (embedded-lilypond parser lily-string filename line closures location) (let* ((clone (ly:parser-clone parser closures location)) - (result (ly:parse-string-expression clone lily-string - filename line))) - (if (ly:parser-has-error? clone) - (ly:parser-error parser (_ "error in #{ ... #}"))) - result)) + (result (ly:parse-string-expression clone lily-string + filename line))) + (if (ly:parser-has-error? clone) + (ly:parser-error parser (_ "error in #{ ... #}"))) + result)) (list embedded-lilypond 'parser lily-string filename line (cons 'list (reverse! closures)) diff --git a/scm/part-combiner.scm b/scm/part-combiner.scm index 279123222b..dadce94863 100644 --- a/scm/part-combiner.scm +++ b/scm/part-combiner.scm @@ -46,10 +46,10 @@ (define-method (previous-voice-state (vs <Voice-state>)) (let ((i (slot-ref vs 'vector-index)) - (v (slot-ref vs 'state-vector))) + (v (slot-ref vs 'state-vector))) (if (< 0 i) - (vector-ref v (1- i)) - #f))) + (vector-ref v (1- i)) + #f))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -62,7 +62,7 @@ ;; voice-states are states starting with the Split-state or later ;; (is #:init-keyword #:voice-states #:accessor voice-states) - (synced #:init-keyword #:synced #:init-value #f #:getter synced?)) + (synced #:init-keyword #:synced #:init-value #f #:getter synced?)) (define-method (write (x <Split-state> ) f) @@ -82,13 +82,13 @@ (define (make-voice-states evl) (let ((vec (list->vector (map (lambda (v) - (make <Voice-state> - #:moment (caar v) - #:tuning (cdar v) - #:events (map car (cdr v)))) - evl)))) + (make <Voice-state> + #:moment (caar v) + #:tuning (cdar v) + #:events (map car (cdr v)))) + evl)))) (do ((i 0 (1+ i))) - ((= i (vector-length vec)) vec) + ((= i (vector-length vec)) vec) (slot-set! (vector-ref vec i) 'vector-index i) (slot-set! (vector-ref vec i) 'state-vector vec)))) @@ -99,29 +99,29 @@ Voice-state objects " (define (helper ss-idx ss-list idx1 idx2) (let* ((state1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f)) - (state2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f)) - (min (cond ((and state1 state2) (moment-min (moment state1) (moment state2))) - (state1 (moment state1)) - (state2 (moment state2)) - (else #f))) - (inc1 (if (and state1 (equal? min (moment state1))) 1 0)) - (inc2 (if (and state2 (equal? min (moment state2))) 1 0)) - (ss-object (if min - (make <Split-state> - #:moment min - #:voice-states (cons state1 state2) - #:synced (= inc1 inc2)) - #f))) + (state2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f)) + (min (cond ((and state1 state2) (moment-min (moment state1) (moment state2))) + (state1 (moment state1)) + (state2 (moment state2)) + (else #f))) + (inc1 (if (and state1 (equal? min (moment state1))) 1 0)) + (inc2 (if (and state2 (equal? min (moment state2))) 1 0)) + (ss-object (if min + (make <Split-state> + #:moment min + #:voice-states (cons state1 state2) + #:synced (= inc1 inc2)) + #f))) (if state1 - (set! (split-index state1) ss-idx)) + (set! (split-index state1) ss-idx)) (if state2 - (set! (split-index state2) ss-idx)) + (set! (split-index state2) ss-idx)) (if min - (helper (1+ ss-idx) - (cons ss-object ss-list) - (+ idx1 inc1) - (+ idx2 inc2)) - ss-list))) + (helper (1+ ss-idx) + (cons ss-object ss-list) + (+ idx1 inc1) + (+ idx2 inc2)) + ss-list))) (list->vector (reverse! (helper 0 '() 0 0) '()))) (define (analyse-spanner-states voice-state-vec) @@ -131,70 +131,70 @@ Voice-state objects (define (analyse-tie-start active ev) (if (ly:in-event-class? ev 'tie-event) - (acons 'tie (split-index (vector-ref voice-state-vec index)) - active) - active)) + (acons 'tie (split-index (vector-ref voice-state-vec index)) + active) + active)) (define (analyse-tie-end active ev) (if (ly:in-event-class? ev 'note-event) - (assoc-remove! active 'tie) - active)) + (assoc-remove! active 'tie) + active)) (define (analyse-absdyn-end active ev) (if (or (ly:in-event-class? ev 'absolute-dynamic-event) - (and (ly:in-event-class? ev 'span-dynamic-event) - (equal? STOP (ly:event-property ev 'span-direction)))) - (assoc-remove! (assoc-remove! active 'cresc) 'decr) - active)) + (and (ly:in-event-class? ev 'span-dynamic-event) + (equal? STOP (ly:event-property ev 'span-direction)))) + (assoc-remove! (assoc-remove! active 'cresc) 'decr) + active)) (define (active<? a b) (cond ((symbol<? (car a) (car b)) #t) - ((symbol<? (car b) (car a)) #f) - (else (< (cdr a) (cdr b))))) + ((symbol<? (car b) (car a)) #f) + (else (< (cdr a) (cdr b))))) (define (analyse-span-event active ev) (let* ((name (car (ly:event-property ev 'class))) - (key (cond ((equal? name 'slur-event) 'slur) - ((equal? name 'phrasing-slur-event) 'tie) - ((equal? name 'beam-event) 'beam) - ((equal? name 'crescendo-event) 'cresc) - ((equal? name 'decrescendo-event) 'decr) - (else #f))) - (sp (ly:event-property ev 'span-direction))) - (if (and (symbol? key) (ly:dir? sp)) - (if (= sp STOP) - (assoc-remove! active key) - (acons key - (split-index (vector-ref voice-state-vec index)) - active)) - active))) + (key (cond ((equal? name 'slur-event) 'slur) + ((equal? name 'phrasing-slur-event) 'tie) + ((equal? name 'beam-event) 'beam) + ((equal? name 'crescendo-event) 'cresc) + ((equal? name 'decrescendo-event) 'decr) + (else #f))) + (sp (ly:event-property ev 'span-direction))) + (if (and (symbol? key) (ly:dir? sp)) + (if (= sp STOP) + (assoc-remove! active key) + (acons key + (split-index (vector-ref voice-state-vec index)) + active)) + active))) (define (analyse-events active evs) "Run all analyzers on ACTIVE and EVS" (define (run-analyzer analyzer active evs) - (if (pair? evs) - (run-analyzer analyzer (analyzer active (car evs)) (cdr evs)) - active)) + (if (pair? evs) + (run-analyzer analyzer (analyzer active (car evs)) (cdr evs)) + active)) (define (run-analyzers analyzers active evs) - (if (pair? analyzers) - (run-analyzers (cdr analyzers) - (run-analyzer (car analyzers) active evs) - evs) - active)) + (if (pair? analyzers) + (run-analyzers (cdr analyzers) + (run-analyzer (car analyzers) active evs) + evs) + active)) (sort ;; todo: use fold or somesuch. (run-analyzers (list analyse-absdyn-end analyse-span-event - ;; note: tie-start/span comes after tie-end/absdyn. - analyse-tie-end analyse-tie-start) - active evs) + ;; note: tie-start/span comes after tie-end/absdyn. + analyse-tie-end analyse-tie-start) + active evs) active<?)) ;; must copy, since we use assoc-remove! (if (< index (vector-length voice-state-vec)) - (begin - (set! active (analyse-events active (events (vector-ref voice-state-vec index)))) - (set! (span-state (vector-ref voice-state-vec index)) - (list-copy active)) - (helper (1+ index) active)))) + (begin + (set! active (analyse-events active (events (vector-ref voice-state-vec index)))) + (set! (span-state (vector-ref voice-state-vec index)) + (list-copy active)) + (helper (1+ index) active)))) (helper 0 '())) @@ -204,69 +204,69 @@ Voice-state objects in a chronological list, similar to the @code{Recording_group_engraver} in LilyPond version 2.8 and earlier." (let* - ((context-list '()) - (now-mom (ly:make-moment 0 0)) - (global (ly:make-global-context odef)) - (mom-listener (ly:make-listener - (lambda (tev) (set! now-mom (ly:event-property tev 'moment))))) - (new-context-listener - (ly:make-listener - (lambda (sev) - (let* - ((child (ly:event-property sev 'context)) - (this-moment-list (cons (ly:context-id child) '())) - (dummy (set! context-list (cons this-moment-list context-list))) - (acc '()) - (accumulate-event-listener - (ly:make-listener (lambda (ev) - (set! acc (cons (cons ev #t) acc))))) - (save-acc-listener - (ly:make-listener (lambda (tev) - (if (pair? acc) - (let ((this-moment - (cons (cons now-mom - (ly:context-property child 'instrumentTransposition)) - ;; The accumulate-event-listener above creates - ;; the list of events in reverse order, so we - ;; have to revert it to the original order again - (reverse acc)))) - (set-cdr! this-moment-list - (cons this-moment (cdr this-moment-list))) - (set! acc '()))))))) - (ly:add-listener accumulate-event-listener - (ly:context-event-source child) 'StreamEvent) - (ly:add-listener save-acc-listener - (ly:context-event-source global) 'OneTimeStep)))))) + ((context-list '()) + (now-mom (ly:make-moment 0 0)) + (global (ly:make-global-context odef)) + (mom-listener (ly:make-listener + (lambda (tev) (set! now-mom (ly:event-property tev 'moment))))) + (new-context-listener + (ly:make-listener + (lambda (sev) + (let* + ((child (ly:event-property sev 'context)) + (this-moment-list (cons (ly:context-id child) '())) + (dummy (set! context-list (cons this-moment-list context-list))) + (acc '()) + (accumulate-event-listener + (ly:make-listener (lambda (ev) + (set! acc (cons (cons ev #t) acc))))) + (save-acc-listener + (ly:make-listener (lambda (tev) + (if (pair? acc) + (let ((this-moment + (cons (cons now-mom + (ly:context-property child 'instrumentTransposition)) + ;; The accumulate-event-listener above creates + ;; the list of events in reverse order, so we + ;; have to revert it to the original order again + (reverse acc)))) + (set-cdr! this-moment-list + (cons this-moment (cdr this-moment-list))) + (set! acc '()))))))) + (ly:add-listener accumulate-event-listener + (ly:context-event-source child) 'StreamEvent) + (ly:add-listener save-acc-listener + (ly:context-event-source global) 'OneTimeStep)))))) (ly:add-listener new-context-listener - (ly:context-events-below global) 'AnnounceNewContext) + (ly:context-events-below global) 'AnnounceNewContext) (ly:add-listener mom-listener (ly:context-event-source global) 'Prepare) (ly:interpret-music-expression (make-non-relative-music music) global) context-list)) (define-public (make-part-combine-music parser music-list direction) (let* ((m (make-music 'PartCombineMusic)) - (m1 (make-non-relative-music (context-spec-music (first music-list) 'Voice "one"))) - (m2 (make-non-relative-music (context-spec-music (second music-list) 'Voice "two"))) - (listener (ly:parser-lookup parser 'partCombineListener)) - (evs2 (recording-group-emulate m2 listener)) - (evs1 (recording-group-emulate m1 listener))) + (m1 (make-non-relative-music (context-spec-music (first music-list) 'Voice "one"))) + (m2 (make-non-relative-music (context-spec-music (second music-list) 'Voice "two"))) + (listener (ly:parser-lookup parser 'partCombineListener)) + (evs2 (recording-group-emulate m2 listener)) + (evs1 (recording-group-emulate m1 listener))) (set! (ly:music-property m 'elements) (list m1 m2)) (set! (ly:music-property m 'direction) direction) (set! (ly:music-property m 'split-list) - (if (and (assoc "one" evs1) (assoc "two" evs2)) - (determine-split-list (reverse! (assoc-get "one" evs1) '()) - (reverse! (assoc-get "two" evs2) '())) - '())) + (if (and (assoc "one" evs1) (assoc "two" evs2)) + (determine-split-list (reverse! (assoc-get "one" evs1) '()) + (reverse! (assoc-get "two" evs2) '())) + '())) m)) (define-public (determine-split-list evl1 evl2) "@var{evl1} and @var{evl2} should be ascending." (let* ((pc-debug #f) - (chord-threshold 8) - (voice-state-vec1 (make-voice-states evl1)) - (voice-state-vec2 (make-voice-states evl2)) - (result (make-split-state voice-state-vec1 voice-state-vec2))) + (chord-threshold 8) + (voice-state-vec1 (make-voice-states evl1)) + (voice-state-vec2 (make-voice-states evl2)) + (result (make-split-state voice-state-vec1 voice-state-vec2))) ;; Go through all moments recursively and check if the events of that ;; moment contain a part-combine-force-event override. If so, store its @@ -275,274 +275,274 @@ LilyPond version 2.8 and earlier." (define (analyse-forced-combine result-idx prev-res) (define (get-forced-event x) - (if (ly:in-event-class? x 'part-combine-force-event) - (cons (ly:event-property x 'forced-type) (ly:event-property x 'once)) - #f)) + (if (ly:in-event-class? x 'part-combine-force-event) + (cons (ly:event-property x 'forced-type) (ly:event-property x 'once)) + #f)) (define (part-combine-events vs) - (if (not vs) - '() - (filter-map get-forced-event (events vs)))) + (if (not vs) + '() + (filter-map get-forced-event (events vs)))) ;; end part-combine-events ;; forced-result: Take the previous config and analyse whether ;; any change happened.... Return new once and permanent config (define (forced-result evt state) - ;; sanity check, evt should always be (new-state . once) - (if (not (and (pair? evt) (pair? state))) - state - (if (cdr evt) - ;; Once-event, leave permanent state unchanged - (cons (car evt) (cdr state)) - ;; permanent change, leave once state unchanged - (cons (car state) (car evt))))) + ;; sanity check, evt should always be (new-state . once) + (if (not (and (pair? evt) (pair? state))) + state + (if (cdr evt) + ;; Once-event, leave permanent state unchanged + (cons (car evt) (cdr state)) + ;; permanent change, leave once state unchanged + (cons (car state) (car evt))))) ;; end forced-combine-result ;; body of analyse-forced-combine: (if (< result-idx (vector-length result)) - (let* ((now-state (vector-ref result result-idx)) ; current result - ;; Extract all part-combine force events - (ev1 (part-combine-events (car (voice-states now-state)))) - (ev2 (part-combine-events (cdr (voice-states now-state)))) - (evts (append ev1 ev2)) - ;; result is (once-state permament-state): - (state (fold forced-result (cons 'automatic prev-res) evts)) - ;; Now let once override permanent changes: - (force-state (if (equal? (car state) 'automatic) - (cdr state) - (car state)))) - (set! (forced-configuration (vector-ref result result-idx)) - force-state) - ;; For the next moment, ignore the once override (car stat) - ;; and pass on the permanent override, stored as (cdr state) - (analyse-forced-combine (1+ result-idx) (cdr state))))) + (let* ((now-state (vector-ref result result-idx)) ; current result + ;; Extract all part-combine force events + (ev1 (part-combine-events (car (voice-states now-state)))) + (ev2 (part-combine-events (cdr (voice-states now-state)))) + (evts (append ev1 ev2)) + ;; result is (once-state permament-state): + (state (fold forced-result (cons 'automatic prev-res) evts)) + ;; Now let once override permanent changes: + (force-state (if (equal? (car state) 'automatic) + (cdr state) + (car state)))) + (set! (forced-configuration (vector-ref result result-idx)) + force-state) + ;; For the next moment, ignore the once override (car stat) + ;; and pass on the permanent override, stored as (cdr state) + (analyse-forced-combine (1+ result-idx) (cdr state))))) ;; end analyse-forced-combine (define (analyse-time-step result-idx) (define (put x . index) - "Put the result to X, starting from INDEX backwards. + "Put the result to X, starting from INDEX backwards. Only set if not set previously. " - (let ((i (if (pair? index) (car index) result-idx))) - (if (and (<= 0 i) - (not (symbol? (configuration (vector-ref result i))))) - (begin - (set! (configuration (vector-ref result i)) x) - (put x (1- i)))))) + (let ((i (if (pair? index) (car index) result-idx))) + (if (and (<= 0 i) + (not (symbol? (configuration (vector-ref result i))))) + (begin + (set! (configuration (vector-ref result i)) x) + (put x (1- i)))))) (define (copy-state-from state-vec vs) - (define (copy-one-state key-idx) - (let* ((idx (cdr key-idx)) - (prev-ss (vector-ref result idx)) - (prev (configuration prev-ss))) - (if (symbol? prev) - (put prev)))) - (map copy-one-state (span-state vs))) + (define (copy-one-state key-idx) + (let* ((idx (cdr key-idx)) + (prev-ss (vector-ref result idx)) + (prev (configuration prev-ss))) + (if (symbol? prev) + (put prev)))) + (map copy-one-state (span-state vs))) (define (analyse-notes now-state) - (let* ((vs1 (car (voice-states now-state))) - (vs2 (cdr (voice-states now-state))) - (notes1 (note-events vs1)) - (durs1 (sort (map (lambda (x) (ly:event-property x 'duration)) - notes1) - ly:duration<?)) - (pitches1 (sort (map (lambda (x) (ly:event-property x 'pitch)) - notes1) - ly:pitch<?)) - (notes2 (note-events vs2)) - (durs2 (sort (map (lambda (x) (ly:event-property x 'duration)) - notes2) - ly:duration<?)) - (pitches2 (sort (map (lambda (x) (ly:event-property x 'pitch)) - notes2) - ly:pitch<?))) - (cond ((> (length notes1) 1) (put 'apart)) - ((> (length notes2) 1) (put 'apart)) - ((= 1 (+ (length notes2) (length notes1))) (put 'apart)) - ((and (= (length durs1) 1) - (= (length durs2) 1) - (not (equal? (car durs1) (car durs2)))) - (put 'apart)) - (else - (if (and (= (length pitches1) (length pitches2))) - (if (and (pair? pitches1) - (pair? pitches2) - (or - (< chord-threshold (ly:pitch-steps - (ly:pitch-diff (car pitches1) - (car pitches2)))) - - ;; voice crossings: - (> 0 (ly:pitch-steps (ly:pitch-diff (car pitches1) - (car pitches2)))) - )) - (put 'apart) - ;; copy previous split state from spanner state - (begin - (if (previous-voice-state vs1) - (copy-state-from voice-state-vec1 - (previous-voice-state vs1))) - (if (previous-voice-state vs2) - (copy-state-from voice-state-vec2 - (previous-voice-state vs2))) - (if (and (null? (span-state vs1)) (null? (span-state vs2))) - (put 'chords))))))))) + (let* ((vs1 (car (voice-states now-state))) + (vs2 (cdr (voice-states now-state))) + (notes1 (note-events vs1)) + (durs1 (sort (map (lambda (x) (ly:event-property x 'duration)) + notes1) + ly:duration<?)) + (pitches1 (sort (map (lambda (x) (ly:event-property x 'pitch)) + notes1) + ly:pitch<?)) + (notes2 (note-events vs2)) + (durs2 (sort (map (lambda (x) (ly:event-property x 'duration)) + notes2) + ly:duration<?)) + (pitches2 (sort (map (lambda (x) (ly:event-property x 'pitch)) + notes2) + ly:pitch<?))) + (cond ((> (length notes1) 1) (put 'apart)) + ((> (length notes2) 1) (put 'apart)) + ((= 1 (+ (length notes2) (length notes1))) (put 'apart)) + ((and (= (length durs1) 1) + (= (length durs2) 1) + (not (equal? (car durs1) (car durs2)))) + (put 'apart)) + (else + (if (and (= (length pitches1) (length pitches2))) + (if (and (pair? pitches1) + (pair? pitches2) + (or + (< chord-threshold (ly:pitch-steps + (ly:pitch-diff (car pitches1) + (car pitches2)))) + + ;; voice crossings: + (> 0 (ly:pitch-steps (ly:pitch-diff (car pitches1) + (car pitches2)))) + )) + (put 'apart) + ;; copy previous split state from spanner state + (begin + (if (previous-voice-state vs1) + (copy-state-from voice-state-vec1 + (previous-voice-state vs1))) + (if (previous-voice-state vs2) + (copy-state-from voice-state-vec2 + (previous-voice-state vs2))) + (if (and (null? (span-state vs1)) (null? (span-state vs2))) + (put 'chords))))))))) (if (< result-idx (vector-length result)) - (let* ((now-state (vector-ref result result-idx)) - (vs1 (car (voice-states now-state))) - (vs2 (cdr (voice-states now-state)))) - - (cond ((not vs1) (put 'apart)) - ((not vs2) (put 'apart)) - (else - (let ((active1 (previous-span-state vs1)) - (active2 (previous-span-state vs2)) - (new-active1 (span-state vs1)) - (new-active2 (span-state vs2))) - (if #f ; debug - (display (list (moment now-state) result-idx - active1 "->" new-active1 - active2 "->" new-active2 - "\n"))) - (if (and (synced? now-state) - (equal? active1 active2) - (equal? new-active1 new-active2)) - (analyse-notes now-state) - - ;; active states different: - (put 'apart))) - - ;; go to the next one, if it exists. - (analyse-time-step (1+ result-idx))))))) + (let* ((now-state (vector-ref result result-idx)) + (vs1 (car (voice-states now-state))) + (vs2 (cdr (voice-states now-state)))) + + (cond ((not vs1) (put 'apart)) + ((not vs2) (put 'apart)) + (else + (let ((active1 (previous-span-state vs1)) + (active2 (previous-span-state vs2)) + (new-active1 (span-state vs1)) + (new-active2 (span-state vs2))) + (if #f ; debug + (display (list (moment now-state) result-idx + active1 "->" new-active1 + active2 "->" new-active2 + "\n"))) + (if (and (synced? now-state) + (equal? active1 active2) + (equal? new-active1 new-active2)) + (analyse-notes now-state) + + ;; active states different: + (put 'apart))) + + ;; go to the next one, if it exists. + (analyse-time-step (1+ result-idx))))))) (define (analyse-a2 result-idx) (if (< result-idx (vector-length result)) - (let* ((now-state (vector-ref result result-idx)) - (vs1 (car (voice-states now-state))) - (vs2 (cdr (voice-states now-state)))) - (if (and (equal? (configuration now-state) 'chords) - vs1 vs2) - (let ((notes1 (note-events vs1)) - (notes2 (note-events vs2))) - (cond ((and (= 1 (length notes1)) - (= 1 (length notes2)) - (equal? (ly:event-property (car notes1) 'pitch) - (ly:event-property (car notes2) 'pitch))) - (set! (configuration now-state) 'unisono)) - ((and (= 0 (length notes1)) - (= 0 (length notes2))) - (set! (configuration now-state) 'unisilence))))) - (analyse-a2 (1+ result-idx))))) + (let* ((now-state (vector-ref result result-idx)) + (vs1 (car (voice-states now-state))) + (vs2 (cdr (voice-states now-state)))) + (if (and (equal? (configuration now-state) 'chords) + vs1 vs2) + (let ((notes1 (note-events vs1)) + (notes2 (note-events vs2))) + (cond ((and (= 1 (length notes1)) + (= 1 (length notes2)) + (equal? (ly:event-property (car notes1) 'pitch) + (ly:event-property (car notes2) 'pitch))) + (set! (configuration now-state) 'unisono)) + ((and (= 0 (length notes1)) + (= 0 (length notes2))) + (set! (configuration now-state) 'unisilence))))) + (analyse-a2 (1+ result-idx))))) (define (analyse-solo12 result-idx) (define (previous-config vs) - (let* ((pvs (previous-voice-state vs)) - (spi (if pvs (split-index pvs) #f)) - (prev-split (if spi (vector-ref result spi) #f))) - (if prev-split - (configuration prev-split) - 'apart))) + (let* ((pvs (previous-voice-state vs)) + (spi (if pvs (split-index pvs) #f)) + (prev-split (if spi (vector-ref result spi) #f))) + (if prev-split + (configuration prev-split) + 'apart))) (define (put-range x a b) - ;; (display (list "put range " x a b "\n")) - (do ((i a (1+ i))) - ((> i b) b) - (set! (configuration (vector-ref result i)) x))) + ;; (display (list "put range " x a b "\n")) + (do ((i a (1+ i))) + ((> i b) b) + (set! (configuration (vector-ref result i)) x))) (define (put x) - ;; (display (list "putting " x "\n")) - (set! (configuration (vector-ref result result-idx)) x)) + ;; (display (list "putting " x "\n")) + (set! (configuration (vector-ref result result-idx)) x)) (define (current-voice-state now-state voice-num) - (define vs ((if (= 1 voice-num) car cdr) - (voice-states now-state))) - (if (or (not vs) (equal? (moment now-state) (moment vs))) - vs - (previous-voice-state vs))) + (define vs ((if (= 1 voice-num) car cdr) + (voice-states now-state))) + (if (or (not vs) (equal? (moment now-state) (moment vs))) + vs + (previous-voice-state vs))) (define (try-solo type start-idx current-idx) - "Find a maximum stretch that can be marked as solo. Only set + "Find a maximum stretch that can be marked as solo. Only set the mark when there are no spanners active. return next idx to analyse. " - (if (< current-idx (vector-length result)) - (let* ((now-state (vector-ref result current-idx)) - (solo-state (current-voice-state now-state (if (equal? type 'solo1) 1 2))) - (silent-state (current-voice-state now-state (if (equal? type 'solo1) 2 1))) - (silent-notes (if silent-state (note-events silent-state) '())) - (solo-notes (if solo-state (note-events solo-state) '()))) - ;; (display (list "trying " type " at " (moment now-state) solo-state silent-state "\n")) - (cond ((not (equal? (configuration now-state) 'apart)) - current-idx) - ((> (length silent-notes) 0) start-idx) - ((not solo-state) - (put-range type start-idx current-idx) - current-idx) - ((and - (null? (span-state solo-state))) - - ;; - ;; This includes rests. This isn't a problem: long rests - ;; will be shared with the silent voice, and be marked - ;; as unisilence. Therefore, long rests won't - ;; accidentally be part of a solo. - ;; - (put-range type start-idx current-idx) - (try-solo type (1+ current-idx) (1+ current-idx))) - (else - (try-solo type start-idx (1+ current-idx))))) - ;; try-solo - start-idx)) + (if (< current-idx (vector-length result)) + (let* ((now-state (vector-ref result current-idx)) + (solo-state (current-voice-state now-state (if (equal? type 'solo1) 1 2))) + (silent-state (current-voice-state now-state (if (equal? type 'solo1) 2 1))) + (silent-notes (if silent-state (note-events silent-state) '())) + (solo-notes (if solo-state (note-events solo-state) '()))) + ;; (display (list "trying " type " at " (moment now-state) solo-state silent-state "\n")) + (cond ((not (equal? (configuration now-state) 'apart)) + current-idx) + ((> (length silent-notes) 0) start-idx) + ((not solo-state) + (put-range type start-idx current-idx) + current-idx) + ((and + (null? (span-state solo-state))) + + ;; + ;; This includes rests. This isn't a problem: long rests + ;; will be shared with the silent voice, and be marked + ;; as unisilence. Therefore, long rests won't + ;; accidentally be part of a solo. + ;; + (put-range type start-idx current-idx) + (try-solo type (1+ current-idx) (1+ current-idx))) + (else + (try-solo type start-idx (1+ current-idx))))) + ;; try-solo + start-idx)) (define (analyse-moment result-idx) - "Analyse 'apart starting at RESULT-IDX. Return next index." - (let* ((now-state (vector-ref result result-idx)) - (vs1 (current-voice-state now-state 1)) - (vs2 (current-voice-state now-state 2)) - ;; (vs1 (car (voice-states now-state))) - ;; (vs2 (cdr (voice-states now-state))) - (notes1 (if vs1 (note-events vs1) '())) - (notes2 (if vs2 (note-events vs2) '())) - (n1 (length notes1)) - (n2 (length notes2))) - ;; (display (list "analyzing step " result-idx " moment " (moment now-state) vs1 vs2 "\n")) - (max - ;; we should always increase. - (cond ((and (= n1 0) (= n2 0)) - (put 'apart-silence) - (1+ result-idx)) - ((and (= n2 0) - (equal? (moment vs1) (moment now-state)) - (null? (previous-span-state vs1))) - (try-solo 'solo1 result-idx result-idx)) - ((and (= n1 0) - (equal? (moment vs2) (moment now-state)) - (null? (previous-span-state vs2))) - (try-solo 'solo2 result-idx result-idx)) - - (else (1+ result-idx))) - ;; analyse-moment - (1+ result-idx)))) + "Analyse 'apart starting at RESULT-IDX. Return next index." + (let* ((now-state (vector-ref result result-idx)) + (vs1 (current-voice-state now-state 1)) + (vs2 (current-voice-state now-state 2)) + ;; (vs1 (car (voice-states now-state))) + ;; (vs2 (cdr (voice-states now-state))) + (notes1 (if vs1 (note-events vs1) '())) + (notes2 (if vs2 (note-events vs2) '())) + (n1 (length notes1)) + (n2 (length notes2))) + ;; (display (list "analyzing step " result-idx " moment " (moment now-state) vs1 vs2 "\n")) + (max + ;; we should always increase. + (cond ((and (= n1 0) (= n2 0)) + (put 'apart-silence) + (1+ result-idx)) + ((and (= n2 0) + (equal? (moment vs1) (moment now-state)) + (null? (previous-span-state vs1))) + (try-solo 'solo1 result-idx result-idx)) + ((and (= n1 0) + (equal? (moment vs2) (moment now-state)) + (null? (previous-span-state vs2))) + (try-solo 'solo2 result-idx result-idx)) + + (else (1+ result-idx))) + ;; analyse-moment + (1+ result-idx)))) (if (< result-idx (vector-length result)) - (if (equal? (configuration (vector-ref result result-idx)) 'apart) - (analyse-solo12 (analyse-moment result-idx)) - (analyse-solo12 (1+ result-idx))))) ; analyse-solo12 + (if (equal? (configuration (vector-ref result result-idx)) 'apart) + (analyse-solo12 (analyse-moment result-idx)) + (analyse-solo12 (1+ result-idx))))) ; analyse-solo12 (analyse-spanner-states voice-state-vec1) (analyse-spanner-states voice-state-vec2) (if #f - (begin - (display voice-state-vec1) - (display "***\n") - (display voice-state-vec2) - (display "***\n") - (display result) - (display "***\n"))) + (begin + (display voice-state-vec1) + (display "***\n") + (display voice-state-vec2) + (display "***\n") + (display result) + (display "***\n"))) ;; Extract all forced combine strategies, i.e. events inserted by ;; \partcombine(Apart|Automatic|SoloI|SoloII|Chords)[Once] @@ -560,11 +560,11 @@ the mark when there are no spanners active. (analyse-solo12 0) ;; (display result) (set! result (map - ;; forced-configuration overrides, if it is set - (lambda (x) (cons (moment x) (or (forced-configuration x) (configuration x)))) - (vector->list result))) + ;; forced-configuration overrides, if it is set + (lambda (x) (cons (moment x) (or (forced-configuration x) (configuration x)))) + (vector->list result))) (if #f ;; pc-debug - (display result)) + (display result)) result)) diff --git a/scm/predefined-fretboards.scm b/scm/predefined-fretboards.scm index d3286c45d1..be46fb3a3f 100644 --- a/scm/predefined-fretboards.scm +++ b/scm/predefined-fretboards.scm @@ -19,40 +19,40 @@ (define-public (parse-terse-string terse-definition) "Parse a @code{fret-diagram-terse} definition string @var{terse-definition} and return a marking list, which can be used with a fretboard grob." - (cdr (fret-parse-terse-definition-string (list '()) terse-definition))) + (cdr (fret-parse-terse-definition-string (list '()) terse-definition))) (define-public (get-chord-shape shape-code tuning base-chord-shapes) "Return the chord shape associated with @var{shape-code} and @var{tuning} in the hash-table @var{base-chord-shapes}." (let ((hash-handle (hash-get-handle base-chord-shapes - (cons shape-code tuning)))) - (if hash-handle - (cdr hash-handle) - '()))) + (cons shape-code tuning)))) + (if hash-handle + (cdr hash-handle) + '()))) (define-public (offset-fret fret-offset diagram-definition) "Add @var{fret-offset} to each fret indication in @var{diagram-definition} and return the resulting verbose @code{fret-diagram-definition}." - (let ((verbose-definition - (if (string? diagram-definition) - (parse-terse-string diagram-definition) - diagram-definition))) - (map (lambda(item) - (let ((code (car item))) - (cond - ((eq? code 'barre) - (list-set! item 3 - (+ fret-offset (list-ref item 3))) - item) - ((eq? code 'capo) - (list-set! item 1 - (+ fret-offset (list-ref item 1))) - item) - ((eq? code 'place-fret) - (list-set! item 2 - (+ fret-offset (list-ref item 2))) - item) - (else item)))) - verbose-definition))) + (let ((verbose-definition + (if (string? diagram-definition) + (parse-terse-string diagram-definition) + diagram-definition))) + (map (lambda(item) + (let ((code (car item))) + (cond + ((eq? code 'barre) + (list-set! item 3 + (+ fret-offset (list-ref item 3))) + item) + ((eq? code 'capo) + (list-set! item 1 + (+ fret-offset (list-ref item 1))) + item) + ((eq? code 'place-fret) + (list-set! item 2 + (+ fret-offset (list-ref item 2))) + item) + (else item)))) + verbose-definition))) diff --git a/scm/ps-to-png.scm b/scm/ps-to-png.scm index 5e78d0c7c0..0becaeef97 100644 --- a/scm/ps-to-png.scm +++ b/scm/ps-to-png.scm @@ -42,9 +42,9 @@ (define (search-executable names) (define (helper path lst) (if (null? (cdr lst)) - (car lst) - (if (search-path path (car lst)) (car lst) - (helper path (cdr lst))))) + (car lst) + (if (search-path path (car lst)) (car lst) + (helper path (cdr lst))))) (let ((path (parse-path (getenv "PATH")))) (helper path names))) @@ -67,33 +67,33 @@ (set! status (system cmd)) (if (not (= status 0)) (begin - (ly:error (_ "~a exited with status: ~S") "GS" status) - (if exit-on-error (exit 1)))) + (ly:error (_ "~a exited with status: ~S") "GS" status) + (if exit-on-error (exit 1)))) status) (define (scale-down-image be-verbose factor file) (define (with-pbm) (let* ((status 0) - (old (string-append file ".old"))) - + (old (string-append file ".old"))) + (rename-file file old) (my-system be-verbose #t (format #f - "pngtopnm \"~a\" | pnmscale -reduce ~a 2>/dev/null | pnmtopng -compression 9 2>/dev/null > \"~a\"" - old factor file)) + "pngtopnm \"~a\" | pnmscale -reduce ~a 2>/dev/null | pnmtopng -compression 9 2>/dev/null > \"~a\"" + old factor file)) (delete-file old))) (with-pbm)) (define-public (ps-page-count ps-name) (let* ((byte-count 10240) - (header (gulp-file ps-name byte-count)) - (first-null (string-index header #\nul)) - (match (string-match "%%Pages: ([0-9]+)" - (if (number? first-null) - (substring header 0 first-null) - header)))) + (header (gulp-file ps-name byte-count)) + (first-null (string-index header #\nul)) + (match (string-match "%%Pages: ([0-9]+)" + (if (number? first-null) + (substring header 0 first-null) + header)))) (if match (string->number (match:substring match 1)) 0))) (define-public (make-ps-images ps-name . rest) @@ -108,25 +108,25 @@ (anti-alias-factor 1)) (let* ((format-str (format #f "~a" pixmap-format)) - (extension (cond - ((string-contains format-str "png") "png") - ((string-contains format-str "jpg") "jpeg") - ((string-contains format-str "jpeg") "jpeg") - (else - (ly:error "Unknown pixmap format ~a" pixmap-format)))) - (base (dir-basename ps-name ".ps" ".eps")) - (png1 (format #f "~a.~a" base extension)) - (pngn (format #f "~a-page%d.~a" base extension)) - (page-count (ps-page-count ps-name)) - (multi-page? (> page-count 1)) - (output-file (if multi-page? pngn png1)) - - (gs-variable-options - (if (string-suffix-ci? ".eps" ps-name) - "-dEPSCrop" - (format #f "-dDEVICEWIDTHPOINTS=~,2f -dDEVICEHEIGHTPOINTS=~,2f" - page-width page-height))) - (cmd (ly:format "~a\ + (extension (cond + ((string-contains format-str "png") "png") + ((string-contains format-str "jpg") "jpeg") + ((string-contains format-str "jpeg") "jpeg") + (else + (ly:error "Unknown pixmap format ~a" pixmap-format)))) + (base (dir-basename ps-name ".ps" ".eps")) + (png1 (format #f "~a.~a" base extension)) + (pngn (format #f "~a-page%d.~a" base extension)) + (page-count (ps-page-count ps-name)) + (multi-page? (> page-count 1)) + (output-file (if multi-page? pngn png1)) + + (gs-variable-options + (if (string-suffix-ci? ".eps" ps-name) + "-dEPSCrop" + (format #f "-dDEVICEWIDTHPOINTS=~,2f -dDEVICEHEIGHTPOINTS=~,2f" + page-width page-height))) + (cmd (ly:format "~a\ ~a\ ~a\ -dGraphicsAlphaBits=4\ @@ -137,46 +137,46 @@ -r~a\ ~S\ -c quit" - (search-gs) - (if be-verbose "" "-q") - gs-variable-options - pixmap-format - output-file - (* anti-alias-factor resolution) ps-name)) - (status 0) - (files '())) + (search-gs) + (if be-verbose "" "-q") + gs-variable-options + pixmap-format + output-file + (* anti-alias-factor resolution) ps-name)) + (status 0) + (files '())) ;; The wrapper on windows cannot handle `=' signs, ;; gs has a workaround with #. (if (eq? PLATFORM 'windows) - (begin - (set! cmd (re-sub "=" "#" cmd)) - (set! cmd (re-sub "-dSAFER " "" cmd)))) + (begin + (set! cmd (re-sub "=" "#" cmd)) + (set! cmd (re-sub "-dSAFER " "" cmd)))) (set! status (my-system be-verbose #f cmd)) (set! files - (if multi-page? - (map - (lambda (n) - (format #f "~a-page~a.png" base (1+ n))) - (iota page-count)) - (list (format #f "~a.png" base)))) - + (if multi-page? + (map + (lambda (n) + (format #f "~a-page~a.png" base (1+ n))) + (iota page-count)) + (list (format #f "~a.png" base)))) + (if (not (= 0 status)) - (begin - (map delete-file files) - (exit 1))) + (begin + (map delete-file files) + (exit 1))) (if (and rename-page-1 multi-page?) - (begin - (rename-file (re-sub "%d" "1" pngn) png1) - (set! files - (cons png1 - (cdr files))) - )) + (begin + (rename-file (re-sub "%d" "1" pngn) png1) + (set! files + (cons png1 + (cdr files))) + )) (if (not (= 1 anti-alias-factor)) - (for-each - (lambda (f) (scale-down-image be-verbose anti-alias-factor f)) files)) + (for-each + (lambda (f) (scale-down-image be-verbose anti-alias-factor f)) files)) files))) diff --git a/scm/safe-utility-defs.scm b/scm/safe-utility-defs.scm index 57941b2b9a..057639d7fa 100644 --- a/scm/safe-utility-defs.scm +++ b/scm/safe-utility-defs.scm @@ -19,12 +19,12 @@ ;;; Author Ian Hulin ;;; Date 16 October 2011 ;;; - + (define-module (scm safe-utility-defs) -#:use-module (ice-9 optargs) -#:export (safe-objects) -#:export-syntax (define-safe-public) -#:re-export-syntax (define*-public)) + #:use-module (ice-9 optargs) + #:export (safe-objects) + #:export-syntax (define-safe-public) + #:re-export-syntax (define*-public)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Safe definitions utility diff --git a/scm/scheme-engravers.scm b/scm/scheme-engravers.scm index c845f21bd3..0766cbc19c 100644 --- a/scm/scheme-engravers.scm +++ b/scm/scheme-engravers.scm @@ -34,70 +34,70 @@ successive measures, and boundaries are shared by adjoining spanners." (elapsed 0)) (make-engraver - (listeners ((measure-counter-event engraver event) - (set! last-measure-seen (ly:context-property context 'currentBarNumber)) - (set! new-measure? #t) - (cond - ((and (= START (ly:event-property event 'span-direction)) - go?) - (begin - (set! stop? #t) - (ly:input-warning - (ly:event-property event 'origin) - "count not ended before another begun"))) - ((= START (ly:event-property event 'span-direction)) - (set! go? #t)) - ((= STOP (ly:event-property event 'span-direction)) - (begin - (set! stop? #t) - (set! go? #f)))))) + (listeners ((measure-counter-event engraver event) + (set! last-measure-seen (ly:context-property context 'currentBarNumber)) + (set! new-measure? #t) + (cond + ((and (= START (ly:event-property event 'span-direction)) + go?) + (begin + (set! stop? #t) + (ly:input-warning + (ly:event-property event 'origin) + "count not ended before another begun"))) + ((= START (ly:event-property event 'span-direction)) + (set! go? #t)) + ((= STOP (ly:event-property event 'span-direction)) + (begin + (set! stop? #t) + (set! go? #f)))))) - ((process-music trans) - (let ((col (ly:context-property context 'currentCommandColumn)) - (now (ly:context-property context 'measurePosition)) - (current-bar (ly:context-property context 'currentBarNumber))) - ;; If the counter has been started, make sure we're in a new bar - ;; before finishing a count-spanner and starting a new one. - ;; Since we consider all CommandColumns encountered, we need this - ;; check so that a count-spanner is not created for each pair. - (if (and (ly:grob? count-spanner) - (> current-bar last-measure-seen)) - (set! new-measure? #t)) - (if new-measure? - (begin - ;; Check if we have the first column of the measure. - ;; The possibility of initial grace notes is considered. - (if (moment<=? now ZERO-MOMENT) - (begin - ;; If we have the first column, finish the previous - ;; counter-spanner (if there is one). - (if (ly:grob? count-spanner) - (begin - (ly:spanner-set-bound! count-spanner RIGHT col) - (ly:pointer-group-interface::add-grob count-spanner 'columns col) - (ly:engraver-announce-end-grob trans count-spanner col) - (set! count-spanner '()))) - ;; if count is over, reset variables - (if stop? - (begin - (set! elapsed 0) - (set! stop? #f))) - ;; if count is in progress, begin a counter object - (if go? - (let* ((c (ly:engraver-make-grob trans 'MeasureCounter col)) - (counter (ly:grob-property c 'count-from))) - (ly:spanner-set-bound! c LEFT col) - (ly:pointer-group-interface::add-grob c 'columns col) - (set! (ly:grob-property c 'count-from) (+ counter elapsed)) - (set! count-spanner c) - (set! elapsed (1+ elapsed)))) - (set! new-measure? #f))))) - (set! last-measure-seen current-bar))) + ((process-music trans) + (let ((col (ly:context-property context 'currentCommandColumn)) + (now (ly:context-property context 'measurePosition)) + (current-bar (ly:context-property context 'currentBarNumber))) + ;; If the counter has been started, make sure we're in a new bar + ;; before finishing a count-spanner and starting a new one. + ;; Since we consider all CommandColumns encountered, we need this + ;; check so that a count-spanner is not created for each pair. + (if (and (ly:grob? count-spanner) + (> current-bar last-measure-seen)) + (set! new-measure? #t)) + (if new-measure? + (begin + ;; Check if we have the first column of the measure. + ;; The possibility of initial grace notes is considered. + (if (moment<=? now ZERO-MOMENT) + (begin + ;; If we have the first column, finish the previous + ;; counter-spanner (if there is one). + (if (ly:grob? count-spanner) + (begin + (ly:spanner-set-bound! count-spanner RIGHT col) + (ly:pointer-group-interface::add-grob count-spanner 'columns col) + (ly:engraver-announce-end-grob trans count-spanner col) + (set! count-spanner '()))) + ;; if count is over, reset variables + (if stop? + (begin + (set! elapsed 0) + (set! stop? #f))) + ;; if count is in progress, begin a counter object + (if go? + (let* ((c (ly:engraver-make-grob trans 'MeasureCounter col)) + (counter (ly:grob-property c 'count-from))) + (ly:spanner-set-bound! c LEFT col) + (ly:pointer-group-interface::add-grob c 'columns col) + (set! (ly:grob-property c 'count-from) (+ counter elapsed)) + (set! count-spanner c) + (set! elapsed (1+ elapsed)))) + (set! new-measure? #f))))) + (set! last-measure-seen current-bar))) - ((finalize trans) - (if go? - (begin - (set! go? #f) - (ly:grob-suicide! count-spanner) - (set! count-spanner '()) - (ly:warning "measure count left unfinished"))))))) + ((finalize trans) + (if go? + (begin + (set! go? #f) + (ly:grob-suicide! count-spanner) + (set! count-spanner '()) + (ly:warning "measure count left unfinished"))))))) diff --git a/scm/script.scm b/scm/script.scm index b5e14bae56..6564d5f2d4 100644 --- a/scm/script.scm +++ b/scm/script.scm @@ -19,336 +19,336 @@ `( ("accent" . ( - (avoid-slur . around) - (padding . 0.20) - (script-stencil . (feta . ("sforzato" . "sforzato"))) - (side-relative-direction . ,DOWN))) + (avoid-slur . around) + (padding . 0.20) + (script-stencil . (feta . ("sforzato" . "sforzato"))) + (side-relative-direction . ,DOWN))) ("accentus" . ( - (script-stencil . (feta . ("uaccentus" . "uaccentus"))) - (side-relative-direction . ,DOWN) - (avoid-slur . ignore) - (padding . 0.20) - (quantize-position . #t) - (script-priority . -100) - (direction . ,UP))) + (script-stencil . (feta . ("uaccentus" . "uaccentus"))) + (side-relative-direction . ,DOWN) + (avoid-slur . ignore) + (padding . 0.20) + (quantize-position . #t) + (script-priority . -100) + (direction . ,UP))) ("circulus" . ( - (script-stencil . (feta . ("circulus" . "circulus"))) - (side-relative-direction . ,DOWN) - (avoid-slur . ignore) - (padding . 0.20) - (quantize-position . #t) - (script-priority . -100) - (direction . ,UP))) + (script-stencil . (feta . ("circulus" . "circulus"))) + (side-relative-direction . ,DOWN) + (avoid-slur . ignore) + (padding . 0.20) + (quantize-position . #t) + (script-priority . -100) + (direction . ,UP))) ("coda" . ( - (script-stencil . (feta . ("coda" . "coda"))) - (padding . 0.20) - (avoid-slur . outside) - (direction . ,UP))) + (script-stencil . (feta . ("coda" . "coda"))) + (padding . 0.20) + (avoid-slur . outside) + (direction . ,UP))) ("comma" . ( - (script-stencil . (feta . ("lcomma" . "rcomma"))) - (quantize-position . #t) - (padding . 0.20) - (avoid-slur . ignore) - (direction . ,UP))) + (script-stencil . (feta . ("lcomma" . "rcomma"))) + (quantize-position . #t) + (padding . 0.20) + (avoid-slur . ignore) + (direction . ,UP))) ("downbow" . ( - (script-stencil . (feta . ("downbow" . "downbow"))) - (padding . 0.20) - (skyline-horizontal-padding . 0.20) - (avoid-slur . around) - (direction . ,UP) - (script-priority . 150))) + (script-stencil . (feta . ("downbow" . "downbow"))) + (padding . 0.20) + (skyline-horizontal-padding . 0.20) + (avoid-slur . around) + (direction . ,UP) + (script-priority . 150))) ("downmordent" . ( - (script-stencil . (feta . ("downmordent" . "downmordent"))) - (padding . 0.20) - (avoid-slur . around) - (direction . ,UP))) + (script-stencil . (feta . ("downmordent" . "downmordent"))) + (padding . 0.20) + (avoid-slur . around) + (direction . ,UP))) ("downprall" . ( - (script-stencil . (feta . ("downprall" . "downprall"))) - (padding . 0.20) - (avoid-slur . around) - (direction . ,UP))) + (script-stencil . (feta . ("downprall" . "downprall"))) + (padding . 0.20) + (avoid-slur . around) + (direction . ,UP))) ("espressivo" . ( - (avoid-slur . around) - (padding . 0.20) - (script-stencil . (feta . ("espr" . "espr"))) - (side-relative-direction . ,DOWN))) + (avoid-slur . around) + (padding . 0.20) + (script-stencil . (feta . ("espr" . "espr"))) + (side-relative-direction . ,DOWN))) ("fermata" . ( - (script-stencil . (feta . ("dfermata" . "ufermata"))) - (padding . 0.20) - (avoid-slur . around) - (script-priority . 4000) - (direction . ,UP))) + (script-stencil . (feta . ("dfermata" . "ufermata"))) + (padding . 0.20) + (avoid-slur . around) + (script-priority . 4000) + (direction . ,UP))) ("flageolet" . ( - (script-stencil . (feta . ("flageolet" . "flageolet"))) - (padding . 0.20) - (avoid-slur . around) ;guessing? - (direction . ,UP))) + (script-stencil . (feta . ("flageolet" . "flageolet"))) + (padding . 0.20) + (avoid-slur . around) ;guessing? + (direction . ,UP))) ("halfopen" . ( - (avoid-slur . outside) - (padding . 0.20) - (script-stencil . (feta . ("halfopen" . "halfopen"))) - (direction . ,UP))) + (avoid-slur . outside) + (padding . 0.20) + (script-stencil . (feta . ("halfopen" . "halfopen"))) + (direction . ,UP))) ("ictus" . ( - (script-stencil . (feta . ("ictus" . "ictus"))) - (side-relative-direction . ,DOWN) - (quantize-position . #t) - (avoid-slur . ignore) - (padding . 0.20) - (script-priority . -100) - (direction . ,DOWN))) + (script-stencil . (feta . ("ictus" . "ictus"))) + (side-relative-direction . ,DOWN) + (quantize-position . #t) + (avoid-slur . ignore) + (padding . 0.20) + (script-priority . -100) + (direction . ,DOWN))) ("lheel" . ( - (script-stencil . (feta . ("upedalheel" . "upedalheel"))) - (padding . 0.20) - (avoid-slur . around) ;guessing? - (direction . ,DOWN))) + (script-stencil . (feta . ("upedalheel" . "upedalheel"))) + (padding . 0.20) + (avoid-slur . around) ;guessing? + (direction . ,DOWN))) ("lineprall" . ( - (script-stencil . (feta . ("lineprall" . "lineprall"))) - (padding . 0.20) - (avoid-slur . around) - (direction . ,UP))) + (script-stencil . (feta . ("lineprall" . "lineprall"))) + (padding . 0.20) + (avoid-slur . around) + (direction . ,UP))) ("longfermata" . ( - (script-stencil . (feta . ("dlongfermata" . "ulongfermata"))) - (padding . 0.20) - (avoid-slur . around) - (direction . ,UP))) + (script-stencil . (feta . ("dlongfermata" . "ulongfermata"))) + (padding . 0.20) + (avoid-slur . around) + (direction . ,UP))) ("ltoe" . ( - (script-stencil . (feta . ("upedaltoe" . "upedaltoe"))) - (padding . 0.20) - (avoid-slur . around) ;guessing? - (direction . ,DOWN))) + (script-stencil . (feta . ("upedaltoe" . "upedaltoe"))) + (padding . 0.20) + (avoid-slur . around) ;guessing? + (direction . ,DOWN))) ("marcato" . ( - (script-stencil . (feta . ("dmarcato" . "umarcato"))) - (padding . 0.20) - (avoid-slur . inside) + (script-stencil . (feta . ("dmarcato" . "umarcato"))) + (padding . 0.20) + (avoid-slur . inside) ;;(staff-padding . ()) - (quantize-position . #t) - (side-relative-direction . ,DOWN))) + (quantize-position . #t) + (side-relative-direction . ,DOWN))) ("mordent" . ( - (script-stencil . (feta . ("mordent" . "mordent"))) - (padding . 0.20) - (avoid-slur . around) - (direction . ,UP))) + (script-stencil . (feta . ("mordent" . "mordent"))) + (padding . 0.20) + (avoid-slur . around) + (direction . ,UP))) ("open" . ( - (avoid-slur . outside) - (padding . 0.20) - (script-stencil . (feta . ("open" . "open"))) - (direction . ,UP))) + (avoid-slur . outside) + (padding . 0.20) + (script-stencil . (feta . ("open" . "open"))) + (direction . ,UP))) ("portato" . ( - (script-stencil . (feta . ("uportato" . "dportato"))) - (avoid-slur . around) - (padding . 0.45) - (side-relative-direction . ,DOWN))) + (script-stencil . (feta . ("uportato" . "dportato"))) + (avoid-slur . around) + (padding . 0.45) + (side-relative-direction . ,DOWN))) ("prall" . ( - (script-stencil . (feta . ("prall" . "prall"))) - (padding . 0.20) - (avoid-slur . around) - (direction . ,UP))) + (script-stencil . (feta . ("prall" . "prall"))) + (padding . 0.20) + (avoid-slur . around) + (direction . ,UP))) ("pralldown" . ( - (script-stencil . (feta . ("pralldown" . "pralldown"))) - (padding . 0.20) - (avoid-slur . around) - (direction . ,UP))) + (script-stencil . (feta . ("pralldown" . "pralldown"))) + (padding . 0.20) + (avoid-slur . around) + (direction . ,UP))) ("prallmordent" . ( - (script-stencil . (feta . ("prallmordent" . "prallmordent"))) - (padding . 0.20) - (avoid-slur . around) - (direction . ,UP))) + (script-stencil . (feta . ("prallmordent" . "prallmordent"))) + (padding . 0.20) + (avoid-slur . around) + (direction . ,UP))) ("prallprall" . ( - (script-stencil . (feta . ("prallprall" . "prallprall"))) - (padding . 0.20) - (avoid-slur . around) - (direction . ,UP))) + (script-stencil . (feta . ("prallprall" . "prallprall"))) + (padding . 0.20) + (avoid-slur . around) + (direction . ,UP))) ("prallup" . ( - (script-stencil . (feta . ("prallup" . "prallup"))) - (padding . 0.20) - (avoid-slur . around) - (direction . ,UP))) + (script-stencil . (feta . ("prallup" . "prallup"))) + (padding . 0.20) + (avoid-slur . around) + (direction . ,UP))) ("reverseturn" . ( - (script-stencil . (feta . ("reverseturn" . "reverseturn"))) - (padding . 0.20) - (avoid-slur . inside) - (direction . ,UP))) + (script-stencil . (feta . ("reverseturn" . "reverseturn"))) + (padding . 0.20) + (avoid-slur . inside) + (direction . ,UP))) ("rheel" . ( - (script-stencil . (feta . ("dpedalheel" . "dpedalheel"))) - (padding . 0.20) - (avoid-slur . around) ;guessing? - (direction . ,UP))) + (script-stencil . (feta . ("dpedalheel" . "dpedalheel"))) + (padding . 0.20) + (avoid-slur . around) ;guessing? + (direction . ,UP))) ("rtoe" . ( - (script-stencil . (feta . ("dpedaltoe" . "dpedaltoe"))) - (padding . 0.20) - (avoid-slur . around) ;guessing? - (direction . ,UP))) + (script-stencil . (feta . ("dpedaltoe" . "dpedaltoe"))) + (padding . 0.20) + (avoid-slur . around) ;guessing? + (direction . ,UP))) ("segno" . ( - (script-stencil . (feta . ("segno" . "segno"))) - (padding . 0.20) - (avoid-slur . outside) - (direction . ,UP))) + (script-stencil . (feta . ("segno" . "segno"))) + (padding . 0.20) + (avoid-slur . outside) + (direction . ,UP))) ("semicirculus" . ( - (script-stencil . (feta . ("dsemicirculus" . "dsemicirculus"))) - (side-relative-direction . ,DOWN) - (quantize-position . #t) - (avoid-slur . ignore) - (padding . 0.20) - (script-priority . -100) - (direction . ,UP))) + (script-stencil . (feta . ("dsemicirculus" . "dsemicirculus"))) + (side-relative-direction . ,DOWN) + (quantize-position . #t) + (avoid-slur . ignore) + (padding . 0.20) + (script-priority . -100) + (direction . ,UP))) ("shortfermata" . ( - (script-stencil . (feta . ("dshortfermata" . "ushortfermata"))) - (padding . 0.20) - (avoid-slur . around) - (direction . ,UP))) + (script-stencil . (feta . ("dshortfermata" . "ushortfermata"))) + (padding . 0.20) + (avoid-slur . around) + (direction . ,UP))) ("signumcongruentiae" . ( - (script-stencil . (feta . ("dsignumcongruentiae" . "usignumcongruentiae"))) - (padding . 0.20) - (avoid-slur . outside) - (direction . ,UP))) + (script-stencil . (feta . ("dsignumcongruentiae" . "usignumcongruentiae"))) + (padding . 0.20) + (avoid-slur . outside) + (direction . ,UP))) ("snappizzicato" . ( - (script-stencil . (feta . ("snappizzicato" . "snappizzicato"))) - (padding . 0.20) - (avoid-slur . outside) - (direction . ,UP))) + (script-stencil . (feta . ("snappizzicato" . "snappizzicato"))) + (padding . 0.20) + (avoid-slur . outside) + (direction . ,UP))) ("staccatissimo" . ( - (avoid-slur . inside) - (quantize-position . #t) - (script-stencil . (feta . ("dstaccatissimo" . "ustaccatissimo"))) - (padding . 0.20) - (skyline-horizontal-padding . 0.10) - (side-relative-direction . ,DOWN))) + (avoid-slur . inside) + (quantize-position . #t) + (script-stencil . (feta . ("dstaccatissimo" . "ustaccatissimo"))) + (padding . 0.20) + (skyline-horizontal-padding . 0.10) + (side-relative-direction . ,DOWN))) ("staccato" . ( - (script-stencil . (feta . ("staccato" . "staccato"))) - (side-relative-direction . ,DOWN) - (quantize-position . #t) - (avoid-slur . inside) - (toward-stem-shift . 0.5) - (padding . 0.20) - (skyline-horizontal-padding . 0.10) - (script-priority . -100))) + (script-stencil . (feta . ("staccato" . "staccato"))) + (side-relative-direction . ,DOWN) + (quantize-position . #t) + (avoid-slur . inside) + (toward-stem-shift . 0.5) + (padding . 0.20) + (skyline-horizontal-padding . 0.10) + (script-priority . -100))) ("stopped" . ( - (script-stencil . (feta . ("stopped" . "stopped"))) - (avoid-slur . inside) - (padding . 0.20) - (direction . ,UP))) + (script-stencil . (feta . ("stopped" . "stopped"))) + (avoid-slur . inside) + (padding . 0.20) + (direction . ,UP))) ("tenuto" . ( - (script-stencil . (feta . ("tenuto" . "tenuto"))) - (quantize-position . #t) - (avoid-slur . inside) - (padding . 0.20) - (side-relative-direction . ,DOWN))) + (script-stencil . (feta . ("tenuto" . "tenuto"))) + (quantize-position . #t) + (avoid-slur . inside) + (padding . 0.20) + (side-relative-direction . ,DOWN))) ("trill" . ( - (script-stencil . (feta . ("trill" . "trill"))) - (direction . ,UP) - (padding . 0.20) - (avoid-slur . outside) - (script-priority . 2000))) + (script-stencil . (feta . ("trill" . "trill"))) + (direction . ,UP) + (padding . 0.20) + (avoid-slur . outside) + (script-priority . 2000))) ("turn" . ( - (script-stencil . (feta . ("turn" . "turn"))) - (avoid-slur . inside) - (padding . 0.20) - (direction . ,UP))) + (script-stencil . (feta . ("turn" . "turn"))) + (avoid-slur . inside) + (padding . 0.20) + (direction . ,UP))) ("upbow" . ( - (script-stencil . (feta . ("upbow" . "upbow"))) - (avoid-slur . around) - (padding . 0.20) - (direction . ,UP) - (script-priority . 150))) + (script-stencil . (feta . ("upbow" . "upbow"))) + (avoid-slur . around) + (padding . 0.20) + (direction . ,UP) + (script-priority . 150))) ("upmordent" . ( - (script-stencil . (feta . ("upmordent" . "upmordent"))) - (padding . 0.20) - (avoid-slur . around) - (direction . ,UP))) + (script-stencil . (feta . ("upmordent" . "upmordent"))) + (padding . 0.20) + (avoid-slur . around) + (direction . ,UP))) ("upprall" . ( - (script-stencil . (feta . ("upprall" . "upprall"))) - (padding . 0.20) - (avoid-slur . around) - (direction . ,UP))) + (script-stencil . (feta . ("upprall" . "upprall"))) + (padding . 0.20) + (avoid-slur . around) + (direction . ,UP))) ("varcoda" . ( - (script-stencil . (feta . ("varcoda" . "varcoda"))) - (padding . 0.20) - (avoid-slur . outside) - (direction . ,UP))) + (script-stencil . (feta . ("varcoda" . "varcoda"))) + (padding . 0.20) + (avoid-slur . outside) + (direction . ,UP))) ("varcomma" . ( - (script-stencil . (feta . ("lvarcomma" . "rvarcomma"))) - (quantize-position . #t) - (padding . 0.20) - (avoid-slur . ignore) - (direction . ,UP))) + (script-stencil . (feta . ("lvarcomma" . "rvarcomma"))) + (quantize-position . #t) + (padding . 0.20) + (avoid-slur . ignore) + (direction . ,UP))) ("verylongfermata" . ( - (script-stencil . (feta . ("dverylongfermata" . "uverylongfermata"))) - (padding . 0.20) - (avoid-slur . around) - (direction . ,UP))) - )) + (script-stencil . (feta . ("dverylongfermata" . "uverylongfermata"))) + (padding . 0.20) + (avoid-slur . around) + (direction . ,UP))) + )) diff --git a/scm/song-util.scm b/scm/song-util.scm index 5eec46fdd6..c0c226d7c2 100644 --- a/scm/song-util.scm +++ b/scm/song-util.scm @@ -77,7 +77,7 @@ (lambda (record) ((record-predicate ,record) record))) (set! ,$make-record (lambda* (#:key ,@slots) - ((record-constructor ,record) ,@(map car slots*)))) + ((record-constructor ,record) ,@(map car slots*)))) (set! ,$copy-record (lambda (record) (,$make-record ,@(apply @@ -160,11 +160,11 @@ If it unsets the property, return @code{#f}." "Return list of all @var{music}'s top-level children." (let ((elt (ly:music-property music 'element)) (elts (ly:music-property music 'elements)) - (arts (ly:music-property music 'articulations))) + (arts (ly:music-property music 'articulations))) (if (pair? arts) - (set! elts (append elts arts))) + (set! elts (append elts arts))) (if (null? elt) - elts + elts (cons elt elts)))) (define-public (find-child music predicate) @@ -193,9 +193,9 @@ If a non-boolean is returned, it is considered the material to recurse." (let* ((elt (car queue)) (stop (function elt))) (process-music (if (boolean? stop) - (if stop - (cdr queue) - (append (music-elements elt) (cdr queue))) - ((if (cheap-list? stop) append cons) - stop (cdr queue))))))) + (if stop + (cdr queue) + (append (music-elements elt) (cdr queue))) + ((if (cheap-list? stop) append cons) + stop (cdr queue))))))) (process-music (list music))) diff --git a/scm/song.scm b/scm/song.scm index 35b7f2f6fa..9bf68fc73d 100644 --- a/scm/song.scm +++ b/scm/song.scm @@ -139,26 +139,26 @@ (define (tempo->beats music) (let* ((tempo-spec (find-child-named music 'SequentialMusic)) (tempo (cond - (tempo-spec - (let ((tempo-event (find-child-named tempo-spec - 'TempoChangeEvent))) - (and tempo-event - (let ((count (ly:music-property tempo-event - 'metronome-count))) - (* (if (pair? count) - (round (/ (+ (car count) (cdr count)) 2)) - count) - (duration->number - (ly:music-property tempo-event 'tempo-unit))))))) - (else + (tempo-spec + (let ((tempo-event (find-child-named tempo-spec + 'TempoChangeEvent))) + (and tempo-event + (let ((count (ly:music-property tempo-event + 'metronome-count))) + (* (if (pair? count) + (round (/ (+ (car count) (cdr count)) 2)) + count) + (duration->number + (ly:music-property tempo-event 'tempo-unit))))))) + (else (format #t "Programming error (tempo->beats): ~a~%" - tempo-spec))))) + tempo-spec))))) (debug-enable 'backtrace) (and tempo - (set! *default-tempo* (property-value - (find-child tempo-spec (lambda (elt) - (music-property? elt 'tempoWholesPerMinute))))) - (round (* tempo (expt 2 (+ 2 (*base-octave-shift*)))))))) + (set! *default-tempo* (property-value + (find-child tempo-spec (lambda (elt) + (music-property? elt 'tempoWholesPerMinute))))) + (round (* tempo (expt 2 (+ 2 (*base-octave-shift*)))))))) (defstruct music-context music @@ -173,8 +173,8 @@ (cond ((music-name? music* 'LyricCombineMusic) (push! (make-music-context #:music music* - #:context (ly:music-property music* 'associated-context)) - music-context-list) + #:context (ly:music-property music* 'associated-context)) + music-context-list) #t) ((and (music-name? music* 'ContextSpeccedMusic) (music-property-value? music* 'context-type 'Lyrics) @@ -182,7 +182,7 @@ (let ((name-node (find-child music* (lambda (node) (music-property? node 'associatedVoice))))) (if name-node (push! (make-music-context #:music music* #:context (property-value name-node)) - music-context-list))) + music-context-list))) #t) (else #f)))) @@ -214,12 +214,12 @@ ((music-name? music '(EventChord LyricEvent)) (let ((lyric-event (find-child-named music 'LyricEvent))) (push! (make-lyrics - #:text (ly:music-property lyric-event 'text) - #:duration (* (duration->number (ly:music-property lyric-event 'duration)) 4) - #:unfinished (and (not (*syllabify*)) (find-child-named music 'HyphenEvent)) - #:ignore-melismata ignore-melismata - #:context current-voice) - lyrics-list)) + #:text (ly:music-property lyric-event 'text) + #:duration (* (duration->number (ly:music-property lyric-event 'duration)) 4) + #:unfinished (and (not (*syllabify*)) (find-child-named music 'HyphenEvent)) + #:ignore-melismata ignore-melismata + #:context current-voice) + lyrics-list)) ;; LilyPond delays applying settings (set! ignore-melismata next-ignore-melismata) (set! current-voice next-current-voice) @@ -227,9 +227,9 @@ ;; skipping ((music-name? music 'SkipMusic) (push! (make-skip - #:duration (* (duration->number (ly:music-property music 'duration)) 4) - #:context current-voice) - lyrics-list) + #:duration (* (duration->number (ly:music-property music 'duration)) 4) + #:context current-voice) + lyrics-list) #t) ;; parameter change ((music-property? music 'ignoreMelismata) @@ -261,7 +261,7 @@ (defstruct score-notes note/rest-list ; list of note and rest instances (verse-block-list '()) ; lyrics attached to notes -- multiple elements are - ; possible for multiple stanzas + ; possible for multiple stanzas ) (defstruct note @@ -295,10 +295,10 @@ (let ((context (ly:music-property music 'context-id)) (children (music-elements music))) (add! (make-score-voice #:context (debug "Changing context" context) - #:elements (append-map (lambda (elt) - (get-notes* elt autobeaming)) - children)) - result-list)) + #:elements (append-map (lambda (elt) + (get-notes* elt autobeaming)) + children)) + result-list)) #t) ;; timing change ((music-property? music 'timeSignatureFraction) @@ -317,10 +317,10 @@ (let ((repeat-count (ly:music-property music 'repeat-count)) (children (music-elements music))) (add! (make-score-repetice #:count repeat-count - #:elements (append-map - (lambda (elt) (get-notes* elt autobeaming)) - children)) - result-list)) + #:elements (append-map + (lambda (elt) (get-notes* elt autobeaming)) + children)) + result-list)) #t) ;; a note or rest ((or (music-name? music 'EventChord) @@ -350,7 +350,7 @@ events)))) (set! in-slur (+ in-slur slur-start (- slur-end))) (let ((note-spec (make-note #:pitch pitch #:duration duration #:joined in-slur - #:origin (ly:music-property note 'origin))) + #:origin (ly:music-property note 'origin))) (last-result (and (not (null? result-list)) (last result-list)))) (set! last-note-spec note-spec) (if (and last-result @@ -363,29 +363,29 @@ (debug "Rest" rest) (let* ((duration (* (duration->number (ly:music-property rest 'duration)) 4)) (rest-spec (make-rest #:duration duration - #:origin (ly:music-property rest 'origin))) + #:origin (ly:music-property rest 'origin))) (last-result (and (not (null? result-list)) (last result-list)))) (if (and last-result (score-notes? last-result)) (set-score-notes-note/rest-list! last-result - (append (score-notes-note/rest-list last-result) - (list rest-spec))) + (append (score-notes-note/rest-list last-result) + (list rest-spec))) (add! (make-score-notes #:note/rest-list (list rest-spec)) result-list)))))) - (filter - (lambda (m) - (not (music-name? m '(RestEvent - NoteEvent - LyricEvent - MultiMeasureRestEvent)))) - (ly:music-property music 'elements))) - ((music-name? music '(RestEvent - NoteEvent - LyricEvent - MultiMeasureRestEvent)) - (make-music 'EventChord - 'elements - (cons music - (ly:music-property music 'articulations)))) + (filter + (lambda (m) + (not (music-name? m '(RestEvent + NoteEvent + LyricEvent + MultiMeasureRestEvent)))) + (ly:music-property music 'elements))) + ((music-name? music '(RestEvent + NoteEvent + LyricEvent + MultiMeasureRestEvent)) + (make-music 'EventChord + 'elements + (cons music + (ly:music-property music 'articulations)))) ;; autobeaming change ((music-property? music 'autoBeaming) (set! autobeaming (property-value music)) @@ -396,21 +396,21 @@ (set! in-slur (+ in-slur change)) (if last-note-spec (set-note-joined! last-note-spec (+ (note-joined last-note-spec) change)))) - #t) + #t) ;; tempo change ((music-property? music 'tempoWholesPerMinute) (set! *tempo-compression* (ly:moment-div *default-tempo* (property-value music))) - #t) + #t) ;; breathe ((music-name? music 'BreathingEvent) (if last-note-spec (let* ((note-duration (note-duration last-note-spec)) (rest-spec (make-rest #:duration (* note-duration (- 1 (*breathe-shortage*))) - #:origin (ly:music-property music 'origin)))) + #:origin (ly:music-property music 'origin)))) (set-note-duration! last-note-spec (* note-duration (*breathe-shortage*))) (add! (make-score-notes #:note/rest-list (list rest-spec)) result-list)) (warning music "\\\\breathe without previous note known")) - #t) + #t) ;; anything else (else #f)))) @@ -503,12 +503,12 @@ (let ((new-context (score-voice-context score))) (if (equal? new-context lyrics-context) (insert-lyrics*! lyrics/skip-list - (append (score-voice-elements score) - (if (null? (cdr score-list)) - '() - (list (make-score-voice #:context context - #:elements (cdr score-list))))) - new-context) + (append (score-voice-elements score) + (if (null? (cdr score-list)) + '() + (list (make-score-voice #:context context + #:elements (cdr score-list))))) + new-context) (insert-lyrics*! lyrics/skip-list (cdr score-list) context)))) ((score-choice? score) (let* ((lists* (score-choice-lists score)) @@ -519,32 +519,32 @@ (score* #f)) (while (and (not score*) (not (null? lists))) - (set! score* (find-lyrics-score (car lists) lyrics-context allow-default)) - (set! lists (cdr lists)) - (if (not score*) - (set! n (+ n 1))) - (if (and (null? lists) - (not allow-default) - (equal? lyrics-context context)) - (begin - (set! allow-default #t) - (set! n 0) - (set! lists (score-choice-lists score))))) + (set! score* (find-lyrics-score (car lists) lyrics-context allow-default)) + (set! lists (cdr lists)) + (if (not score*) + (set! n (+ n 1))) + (if (and (null? lists) + (not allow-default) + (equal? lyrics-context context)) + (begin + (set! allow-default #t) + (set! n 0) + (set! lists (score-choice-lists score))))) (debug "Selected score" score*) (if (and score* (>= n n-assigned)) (begin (if (> n n-assigned) (receive (assigned-elts unassigned-elts) (split-at lists* n-assigned) - (set-score-choice-lists! score (append assigned-elts - (list (list-ref lists* n)) - (take unassigned-elts (- n n-assigned)) - lists)))) + (set-score-choice-lists! score (append assigned-elts + (list (list-ref lists* n)) + (take unassigned-elts (- n n-assigned)) + lists)))) (set-score-choice-n-assigned! score (+ n-assigned 1)))) (insert-lyrics*! lyrics/skip-list (append (if score* (list score*) '()) (cdr score-list)) context))) ((score-repetice? score) (insert-lyrics*! lyrics/skip-list - (append (score-repetice-elements score) (cdr score-list)) context)) + (append (score-repetice-elements score) (cdr score-list)) context)) ((score-notes? score) ;; This is the only part which actually attaches the processed lyrics. ;; The subsequent calls return verses which we collect into a verse block. @@ -563,66 +563,66 @@ (unfinished-verse #f) (verse-list '())) (while (not (null? note-list)) - (if (null? lyrics/skip-list) - (let ((final-rests '())) - (while (and (not (null? note-list)) - (rest? (car note-list))) - (push! (car note-list) final-rests) - (set! note-list (cdr note-list))) - (if (not (null? final-rests)) - (set! verse-list (append verse-list - (list (make-verse #:text "" + (if (null? lyrics/skip-list) + (let ((final-rests '())) + (while (and (not (null? note-list)) + (rest? (car note-list))) + (push! (car note-list) final-rests) + (set! note-list (cdr note-list))) + (if (not (null? final-rests)) + (set! verse-list (append verse-list + (list (make-verse #:text "" #:notelist/rests (reverse! final-rests)))))) - (if (not (null? note-list)) - (begin - (warning (car note-list) "Missing lyrics: ~a ~a" context note-list) - (set! note-list '())))) - (let ((lyrics/skip (car lyrics/skip-list))) - (receive (notelist/rest note-list*) (if (lyrics? lyrics/skip) - (consume-lyrics-notes lyrics/skip note-list context) - (consume-skip-notes lyrics/skip note-list context)) - (debug "Consumed notes" (list lyrics/skip notelist/rest)) - (set! note-list note-list*) - (cond - ((null? notelist/rest) - #f) - ;; Lyrics - ((and (lyrics? lyrics/skip) - unfinished-verse) - (set-verse-text! - unfinished-verse - (string-append (verse-text unfinished-verse) (lyrics-text lyrics/skip))) - (set-verse-notelist/rests! - unfinished-verse - (append (verse-notelist/rests unfinished-verse) (list notelist/rest))) - (if (not (lyrics-unfinished lyrics/skip)) - (set! unfinished-verse #f))) - ((lyrics? lyrics/skip) - (let ((verse (make-verse #:text (if (rest? notelist/rest) - "" - (lyrics-text lyrics/skip)) - #:notelist/rests (list notelist/rest)))) - (add! verse verse-list) - (set! unfinished-verse (if (lyrics-unfinished lyrics/skip) verse #f)))) - ;; Skip - ((skip? lyrics/skip) - (cond - ((rest? notelist/rest) - (if (null? verse-list) - (set! verse-list (list (make-verse #:text "" - #:notelist/rests (list notelist/rest)))) - (let ((last-verse (last verse-list))) - (set-verse-notelist/rests! - last-verse - (append (verse-notelist/rests last-verse) (list notelist/rest)))))) - ((pair? notelist/rest) - (add! (make-verse #:text (*skip-word*) #:notelist/rests (list notelist/rest)) - verse-list)) - (else - (error "Unreachable branch reached"))) - (set! unfinished-verse #f))) - (if (not (rest? notelist/rest)) - (set! lyrics/skip-list (cdr lyrics/skip-list))))))) + (if (not (null? note-list)) + (begin + (warning (car note-list) "Missing lyrics: ~a ~a" context note-list) + (set! note-list '())))) + (let ((lyrics/skip (car lyrics/skip-list))) + (receive (notelist/rest note-list*) (if (lyrics? lyrics/skip) + (consume-lyrics-notes lyrics/skip note-list context) + (consume-skip-notes lyrics/skip note-list context)) + (debug "Consumed notes" (list lyrics/skip notelist/rest)) + (set! note-list note-list*) + (cond + ((null? notelist/rest) + #f) + ;; Lyrics + ((and (lyrics? lyrics/skip) + unfinished-verse) + (set-verse-text! + unfinished-verse + (string-append (verse-text unfinished-verse) (lyrics-text lyrics/skip))) + (set-verse-notelist/rests! + unfinished-verse + (append (verse-notelist/rests unfinished-verse) (list notelist/rest))) + (if (not (lyrics-unfinished lyrics/skip)) + (set! unfinished-verse #f))) + ((lyrics? lyrics/skip) + (let ((verse (make-verse #:text (if (rest? notelist/rest) + "" + (lyrics-text lyrics/skip)) + #:notelist/rests (list notelist/rest)))) + (add! verse verse-list) + (set! unfinished-verse (if (lyrics-unfinished lyrics/skip) verse #f)))) + ;; Skip + ((skip? lyrics/skip) + (cond + ((rest? notelist/rest) + (if (null? verse-list) + (set! verse-list (list (make-verse #:text "" + #:notelist/rests (list notelist/rest)))) + (let ((last-verse (last verse-list))) + (set-verse-notelist/rests! + last-verse + (append (verse-notelist/rests last-verse) (list notelist/rest)))))) + ((pair? notelist/rest) + (add! (make-verse #:text (*skip-word*) #:notelist/rests (list notelist/rest)) + verse-list)) + (else + (error "Unreachable branch reached"))) + (set! unfinished-verse #f))) + (if (not (rest? notelist/rest)) + (set! lyrics/skip-list (cdr lyrics/skip-list))))))) (if unfinished-verse (set-verse-unfinished! unfinished-verse #t)) (set-score-notes-verse-block-list! @@ -642,13 +642,13 @@ (consumed '())) (while (and join (not (null? note-list))) - (let ((note (car note-list))) - (push! note consumed) - (let ((note-slur (note-joined note))) - (if (< note-slur 0) - (warning note "Slur underrun")) - (set! join (and (not ignore-melismata) (> note-slur 0))))) - (set! note-list (cdr note-list))) + (let ((note (car note-list))) + (push! note consumed) + (let ((note-slur (note-joined note))) + (if (< note-slur 0) + (warning note "Slur underrun")) + (set! join (and (not ignore-melismata) (> note-slur 0))))) + (set! note-list (cdr note-list))) (if join (warning (safe-car (if (null? note-list) consumed note-list)) "Unfinished slur: ~a ~a" context consumed)) @@ -662,19 +662,19 @@ (consumed '())) (while (and (> duration epsilon) (not (null? note-list))) - (let ((note (car note-list))) - (assert (note? note)) - (push! note consumed) - (set! duration (- duration (note-duration note)))) - (set! note-list (cdr note-list))) + (let ((note (car note-list))) + (assert (note? note)) + (push! note consumed) + (set! duration (- duration (note-duration note)))) + (set! note-list (cdr note-list))) (set! consumed (reverse! consumed)) (cond ((> duration epsilon) (warning (if (null? note-list) (safe-last consumed) (safe-car note-list)) - "Excessive skip: ~a ~a ~a ~a" context skip duration consumed)) + "Excessive skip: ~a ~a ~a ~a" context skip duration consumed)) ((< duration (- epsilon)) (warning (if (null? note-list) (safe-last consumed) (safe-car note-list)) - "Skip misalignment: ~a ~a ~a ~a" context skip duration consumed))) + "Skip misalignment: ~a ~a ~a ~a" context skip duration consumed))) (values (if (*skip-word*) consumed '()) @@ -694,8 +694,8 @@ (score-choice-lists score))))) ((score-repetice? score) (list (make-repeated-blocks #:count (score-repetice-count score) - #:block-list (append-map extract-verse-blocks - (score-repetice-elements score))))) + #:block-list (append-map extract-verse-blocks + (score-repetice-elements score))))) ((score-notes? score) (list (make-parallel-blocks #:block-list (score-notes-verse-block-list score)))) (else @@ -709,20 +709,20 @@ (debug "Final score list" score-list) (let ((verse-block-list (debug "Verse blocks" (append-map extract-verse-blocks score-list)))) (letrec ((combine (lambda (lst-1 lst-2) - (debug "Combining lists" (list lst-1 lst-2)) - (if (null? lst-2) - lst-1 - (let ((diff (- (length lst-1) (length lst-2)))) - (if (< diff 0) - (let ((last-elt (last lst-1))) - (while (< diff 0) - (add! last-elt lst-1) - (set! diff (+ diff 1)))) - (let ((last-elt (last lst-2))) - (while (> diff 0) - (add! last-elt lst-2) - (set! diff (- diff 1))))) - (debug "Combined" (map append lst-1 lst-2)))))) + (debug "Combining lists" (list lst-1 lst-2)) + (if (null? lst-2) + lst-1 + (let ((diff (- (length lst-1) (length lst-2)))) + (if (< diff 0) + (let ((last-elt (last lst-1))) + (while (< diff 0) + (add! last-elt lst-1) + (set! diff (+ diff 1)))) + (let ((last-elt (last lst-2))) + (while (> diff 0) + (add! last-elt lst-2) + (set! diff (- diff 1))))) + (debug "Combined" (map append lst-1 lst-2)))))) (expand* (lambda (block) (cond ((parallel-blocks? block) @@ -736,13 +736,13 @@ (expanded (expand (repeated-blocks-block-list block))) (expanded* '())) (while (not (null? expanded)) - (let ((count* count) - (item '())) - (while (and (> count* 0) (not (null? expanded))) - (set! item (append item (car expanded))) - (set! expanded (cdr expanded)) - (set! count* (- count* 1))) - (push! item expanded*))) + (let ((count* count) + (item '())) + (while (and (> count* 0) (not (null? expanded))) + (set! item (append item (car expanded))) + (set! expanded (cdr expanded)) + (set! count* (- count* 1))) + (push! item expanded*))) (reverse expanded*))) (else (list (list block)))))) @@ -751,7 +751,7 @@ (if (null? block-list) '() (debug "Expanded" (combine (expand* (car block-list)) - (expand (cdr block-list))))))) + (expand (cdr block-list))))))) (merge (lambda (verse-list) (cond ((null? verse-list) @@ -760,15 +760,15 @@ (let ((verse-1 (first verse-list)) (verse-2 (second verse-list))) (merge (cons (make-verse #:text (string-append (verse-text verse-1) - (verse-text verse-2)) - #:notelist/rests (append (verse-notelist/rests verse-1) - (verse-notelist/rests verse-2)) - #:unfinished (verse-unfinished verse-2)) + (verse-text verse-2)) + #:notelist/rests (append (verse-notelist/rests verse-1) + (verse-notelist/rests verse-2)) + #:unfinished (verse-unfinished verse-2)) (cddr verse-list))))) (else (cons (car verse-list) (merge (cdr verse-list)))))))) (debug "Final verses" (merge (append-map (lambda (lst) (append-map verse-block-verse-list lst)) - (expand verse-block-list))))))) + (expand verse-block-list))))))) (define (handle-music music) ;; Returns list of verses. @@ -791,7 +791,7 @@ (define festival-note-mapping '((0 "C") (1 "C#") (2 "D") (3 "D#") (4 "E") (5 "F") (6 "F#") - (7 "G") (8 "G#") (9 "A") (10 "A#") (11 "B"))) + (7 "G") (8 "G#") (9 "A") (10 "A#") (11 "B"))) (define (festival-pitch pitch) (let* ((semitones (ly:pitch-semitones pitch)) (octave (inexact->exact (floor (/ semitones 12)))) @@ -815,17 +815,17 @@ (let ((text (verse-text verse)) (note/rest-list (verse-notelist/rests verse))) (receive (rest-list note-listlist) (partition rest? note/rest-list) - (debug "Rest list" rest-list) - (debug "Note list" note-listlist) - (if (not (null? rest-list)) - (set! rest-dur (+ rest-dur (apply + (map rest-duration rest-list))))) - (if (not (null? note-listlist)) - (begin - (if (> rest-dur 0) - (begin - (write-rest-element port rest-dur) - (set! rest-dur 0))) - (write-lyrics-element port text note-listlist)))))) + (debug "Rest list" rest-list) + (debug "Note list" note-listlist) + (if (not (null? rest-list)) + (set! rest-dur (+ rest-dur (apply + (map rest-duration rest-list))))) + (if (not (null? note-listlist)) + (begin + (if (> rest-dur 0) + (begin + (write-rest-element port rest-dur) + (set! rest-dur 0))) + (write-lyrics-element port text note-listlist)))))) (handle-music music)) (if (> rest-dur 0) (write-rest-element port rest-dur)))) diff --git a/scm/standalone.scm b/scm/standalone.scm index bd3b7593ac..ee44d43878 100644 --- a/scm/standalone.scm +++ b/scm/standalone.scm @@ -24,26 +24,26 @@ (define (gulp-file name) (let* ((file (open-input-file name)) - (text (read-delimited "" file))) + (text (read-delimited "" file))) (close file) text)) (define (scm-gulp-file name) - (set! %load-path - (cons (string-append (getenv "LILYPOND_DATADIR") "/ly") - (cons (string-append (getenv "LILYPOND_DATADIR") "/ps") - %load-path))) + (set! %load-path + (cons (string-append (getenv "LILYPOND_DATADIR") "/ly") + (cons (string-append (getenv "LILYPOND_DATADIR") "/ps") + %load-path))) (let ((path (%search-load-path name))) - (if path - (gulp-file path) - (gulp-file name)))) + (if path + (gulp-file path) + (gulp-file name)))) (define (scm-number->string x) (let ((e (inexact->exact x))) (string-append (if (= e x) - (number->string e) - (number->string x)) - " "))) + (number->string e) + (number->string x)) + " "))) (define ly:gulp-file scm-gulp-file) (define ly:number->string scm-number->string) diff --git a/scm/stencil.scm b/scm/stencil.scm index d492f17a1c..8bbbed086f 100644 --- a/scm/stencil.scm +++ b/scm/stencil.scm @@ -34,10 +34,10 @@ ,(car (list-ref coords 6)) ,(cdr (list-ref coords 6)) closepath))) - (ly:make-stencil - `(path ,thick `(,@' ,command-list) 'round 'round #t) - xext - yext))) + (ly:make-stencil + `(path ,thick `(,@' ,command-list) 'round 'round #t) + xext + yext))) (define-public (stack-stencils axis dir padding stils) "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using @@ -85,16 +85,16 @@ a list of @var{paddings}." "Add brackets around @var{stil}, producing a new stencil." (let* ((ext (ly:stencil-extent stil axis)) - (lb (ly:bracket axis ext thick protrusion)) - (rb (ly:bracket axis ext thick (- protrusion)))) + (lb (ly:bracket axis ext thick protrusion)) + (rb (ly:bracket axis ext thick (- protrusion)))) (set! stil - (ly:stencil-combine-at-edge stil (other-axis axis) 1 rb padding)) + (ly:stencil-combine-at-edge stil (other-axis axis) 1 rb padding)) (set! stil - (ly:stencil-combine-at-edge stil (other-axis axis) -1 lb padding)) + (ly:stencil-combine-at-edge stil (other-axis axis) -1 lb padding)) stil)) (define (make-parenthesis-stencil - y-extent half-thickness width angularity) + y-extent half-thickness width angularity) "Create a parenthesis stencil. @var{y-extent} is the Y extent of the markup inside the parenthesis. @var{half-thickness} is the half thickness of the parenthesis. @@ -102,70 +102,70 @@ a list of @var{paddings}." The higher the value of number @var{angularity}, the more angular the shape of the parenthesis." (let* ((line-width 0.1) - ;; Horizontal position of baseline that end points run through. - (base-x - (if (< width 0) - (- width) - 0)) + ;; Horizontal position of baseline that end points run through. + (base-x + (if (< width 0) + (- width) + 0)) ;; X value farthest from baseline on outside of curve (outer-x (+ base-x width)) ;; X extent of bezier sandwich centerline curves (x-extent (ordered-cons base-x outer-x)) - (bottom-y (interval-start y-extent)) - (top-y (interval-end y-extent)) - - (lower-end-point (cons base-x bottom-y)) - (upper-end-point (cons base-x top-y)) - - (outer-control-x (+ base-x (* 4/3 width))) - (inner-control-x (+ outer-control-x - (if (< width 0) - half-thickness - (- half-thickness)))) - - ;; Vertical distance between a control point - ;; and the end point it connects to. - (offset-index (- (* 0.6 angularity) 0.8)) - (lower-control-y (interval-index y-extent offset-index)) - (upper-control-y (interval-index y-extent (- offset-index))) - - (lower-outer-control-point - (cons outer-control-x lower-control-y)) - (upper-outer-control-point - (cons outer-control-x upper-control-y)) - (upper-inner-control-point - (cons inner-control-x upper-control-y)) - (lower-inner-control-point - (cons inner-control-x lower-control-y))) + (bottom-y (interval-start y-extent)) + (top-y (interval-end y-extent)) + + (lower-end-point (cons base-x bottom-y)) + (upper-end-point (cons base-x top-y)) + + (outer-control-x (+ base-x (* 4/3 width))) + (inner-control-x (+ outer-control-x + (if (< width 0) + half-thickness + (- half-thickness)))) + + ;; Vertical distance between a control point + ;; and the end point it connects to. + (offset-index (- (* 0.6 angularity) 0.8)) + (lower-control-y (interval-index y-extent offset-index)) + (upper-control-y (interval-index y-extent (- offset-index))) + + (lower-outer-control-point + (cons outer-control-x lower-control-y)) + (upper-outer-control-point + (cons outer-control-x upper-control-y)) + (upper-inner-control-point + (cons inner-control-x upper-control-y)) + (lower-inner-control-point + (cons inner-control-x lower-control-y))) (make-bezier-sandwich-stencil - (list - ;; Step 4: curve through inner control points - ;; to lower end point. - upper-inner-control-point - lower-inner-control-point - lower-end-point - ;; Step 3: move to upper end point. - upper-end-point - ;; Step 2: curve through outer control points - ;; to upper end point. - lower-outer-control-point - upper-outer-control-point - upper-end-point - ;; Step 1: move to lower end point. - lower-end-point) - line-width - (interval-widen x-extent (/ line-width 2)) - (interval-widen y-extent (/ line-width 2))))) + (list + ;; Step 4: curve through inner control points + ;; to lower end point. + upper-inner-control-point + lower-inner-control-point + lower-end-point + ;; Step 3: move to upper end point. + upper-end-point + ;; Step 2: curve through outer control points + ;; to upper end point. + lower-outer-control-point + upper-outer-control-point + upper-end-point + ;; Step 1: move to lower end point. + lower-end-point) + line-width + (interval-widen x-extent (/ line-width 2)) + (interval-widen y-extent (/ line-width 2))))) (define-public (parenthesize-stencil - stencil half-thickness width angularity padding) + stencil half-thickness width angularity padding) "Add parentheses around @var{stencil}, returning a new stencil." (let* ((y-extent (ly:stencil-extent stencil Y)) - (lp (make-parenthesis-stencil - y-extent half-thickness (- width) angularity)) - (rp (make-parenthesis-stencil - y-extent half-thickness width angularity))) + (lp (make-parenthesis-stencil + y-extent half-thickness (- width) angularity)) + (rp (make-parenthesis-stencil + y-extent half-thickness width angularity))) (set! stencil (ly:stencil-combine-at-edge stencil X LEFT lp padding)) (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT rp padding)) stencil)) @@ -175,30 +175,30 @@ the more angular the shape of the parenthesis." (let ((xext (cons (min startx endx) (max startx endx))) (yext (cons (min starty endy) (max starty endy)))) (ly:make-stencil - (list 'draw-line width startx starty endx endy) - ;; Since the line has rounded edges, we have to / can safely add half the - ;; width to all coordinates! - (interval-widen xext (/ width 2)) - (interval-widen yext (/ width 2))))) + (list 'draw-line width startx starty endx endy) + ;; Since the line has rounded edges, we have to / can safely add half the + ;; width to all coordinates! + (interval-widen xext (/ width 2)) + (interval-widen yext (/ width 2))))) (define-public (make-filled-box-stencil xext yext) "Make a filled box." (ly:make-stencil - (list 'round-filled-box (- (car xext)) (cdr xext) - (- (car yext)) (cdr yext) 0.0) - xext yext)) + (list 'round-filled-box (- (car xext)) (cdr xext) + (- (car yext)) (cdr yext) 0.0) + xext yext)) (define-public (make-circle-stencil radius thickness fill) "Make a circle of radius @var{radius} and thickness @var{thickness}." (let* ((out-radius (+ radius (/ thickness 2.0)))) - (ly:make-stencil - (list 'circle radius thickness fill) - (cons (- out-radius) out-radius) - (cons (- out-radius) out-radius)))) + (ly:make-stencil + (list 'circle radius thickness fill) + (cons (- out-radius) out-radius) + (cons (- out-radius) out-radius)))) (define-public (make-oval-stencil x-radius y-radius thickness fill) "Make an oval from two Bezier curves, of x@tie{}radius @var{x-radius}, @@ -216,14 +216,14 @@ defined by @code{fill}." ,(list 'curveto x-min y-min x-max y-min x-max 0) ,(list 'closepath))) (command-list (fold-right append '() commands))) - (ly:make-stencil - `(path ,thickness `(,@',command-list) 'round 'round ,fill) - (cons (- x-out-radius) x-out-radius) - (cons (- y-out-radius) y-out-radius)))) + (ly:make-stencil + `(path ,thickness `(,@',command-list) 'round 'round ,fill) + (cons (- x-out-radius) x-out-radius) + (cons (- y-out-radius) y-out-radius)))) (define-public (make-partial-ellipse-stencil - x-radius y-radius start-angle end-angle thick connect fill) + x-radius y-radius start-angle end-angle thick connect fill) "Create an elliptical arc @var{x-radius} is the X radius of the arc. @var{y-radius} is the Y radius of the arc. @@ -238,7 +238,7 @@ be connected to the start by a line. the partial ellipse until 7*PI/2. For example, in pseudo-code: > (make-radius-list 2 3) ((0.0 . 2) (PI/2 . 3) (PI . -2) (3*PI/2 . -3) -(2*PI . 2) (5*PI/2 . 3) (3*PI . -2) (7*PI/2 . -3)) + (2*PI . 2) (5*PI/2 . 3) (3*PI . -2) (7*PI/2 . -3)) " (apply append (map (lambda (adder) @@ -363,38 +363,38 @@ then reduce using @var{min-max}: (define (bezier-part-min-max x1 x2 x3 x4) ((lambda (x) (list (reduce min 10000 x) (reduce max -10000 x))) - (map - (lambda (x) - (+ (* x1 (expt (- 1 x) 3)) - (+ (* 3 (* x2 (* (expt (- 1 x) 2) x))) - (+ (* 3 (* x3 (* (- 1 x) (expt x 2)))) - (* x4 (expt x 3)))))) - (if (< (+ (expt x2 2) (+ (expt x3 2) (* x1 x4))) - (+ (* x1 x3) (+ (* x2 x4) (* x2 x3)))) + (map + (lambda (x) + (+ (* x1 (expt (- 1 x) 3)) + (+ (* 3 (* x2 (* (expt (- 1 x) 2) x))) + (+ (* 3 (* x3 (* (- 1 x) (expt x 2)))) + (* x4 (expt x 3)))))) + (if (< (+ (expt x2 2) (+ (expt x3 2) (* x1 x4))) + (+ (* x1 x3) (+ (* x2 x4) (* x2 x3)))) + (list 0.0 1.0) + (filter + (lambda (x) (and (>= x 0) (<= x 1))) + (append (list 0.0 1.0) - (filter - (lambda (x) (and (>= x 0) (<= x 1))) - (append - (list 0.0 1.0) - (map (lambda (op) - (if (not (eqv? 0.0 - (exact->inexact (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2)))))) - ;; Zeros of the bezier curve - (/ (+ (- x1 (* 2 x2)) - (op x3 - (sqrt (- (+ (expt x2 2) - (+ (expt x3 2) (* x1 x4))) - (+ (* x1 x3) - (+ (* x2 x4) (* x2 x3))))))) - (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2)))) - ;; Apply L'hopital's rule to get the zeros if 0/0 - (* (op 0 1) - (/ (/ (- x4 x3) 2) - (sqrt (- (+ (* x2 x2) - (+ (* x3 x3) (* x1 x4))) + (map (lambda (op) + (if (not (eqv? 0.0 + (exact->inexact (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2)))))) + ;; Zeros of the bezier curve + (/ (+ (- x1 (* 2 x2)) + (op x3 + (sqrt (- (+ (expt x2 2) + (+ (expt x3 2) (* x1 x4))) (+ (* x1 x3) - (+ (* x2 x4) (* x2 x3))))))))) - (list + -)))))))) + (+ (* x2 x4) (* x2 x3))))))) + (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2)))) + ;; Apply L'hopital's rule to get the zeros if 0/0 + (* (op 0 1) + (/ (/ (- x4 x3) 2) + (sqrt (- (+ (* x2 x2) + (+ (* x3 x3) (* x1 x4))) + (+ (* x1 x3) + (+ (* x2 x4) (* x2 x3))))))))) + (list + -)))))))) (define (bezier-min-max x1 y1 x2 y2 x3 y3 x4 y4) (map (lambda (x) @@ -410,21 +410,21 @@ then reduce using @var{min-max}: ((lambda (x) (list - (reduce min +inf.0 (map caar x)) - (reduce max -inf.0 (map cadar x)) - (reduce min +inf.0 (map caadr x)) - (reduce max -inf.0 (map cadadr x)))) - (map (lambda (x) - (if (= (length x) 8) - (apply bezier-min-max x) - (apply line-min-max x))) - (map (lambda (x y) - (append (list (cadr (reverse x)) (car (reverse x))) y)) - (append (list origin) - (reverse (cdr (reverse pointlist)))) pointlist)))) + (reduce min +inf.0 (map caar x)) + (reduce max -inf.0 (map cadar x)) + (reduce min +inf.0 (map caadr x)) + (reduce max -inf.0 (map cadadr x)))) + (map (lambda (x) + (if (= (length x) 8) + (apply bezier-min-max x) + (apply line-min-max x))) + (map (lambda (x y) + (append (list (cadr (reverse x)) (car (reverse x))) y)) + (append (list origin) + (reverse (cdr (reverse pointlist)))) pointlist)))) (define-public (make-connected-path-stencil pointlist thickness - x-scale y-scale connect fill) + x-scale y-scale connect fill) "Make a connected path described by the list @var{pointlist}, with thickness @var{thickness}, and scaled by @var{x-scale} in the X direction and @var{y-scale} in the Y direction. @var{connect} and @var{fill} are @@ -433,48 +433,48 @@ respectively." ;; paths using this routine are designed to begin at point '(0 . 0) (let* ((origin (list 0 0)) - (boundlist (path-min-max origin pointlist)) - ;; modify pointlist to scale the coordinates - (path (map (lambda (x) - (apply - (if (= 6 (length x)) - (lambda (x1 x2 x3 x4 x5 x6) - (list 'curveto - (* x1 x-scale) - (* x2 y-scale) - (* x3 x-scale) - (* x4 y-scale) - (* x5 x-scale) - (* x6 y-scale))) - (lambda (x1 x2) - (list 'lineto - (* x1 x-scale) - (* x2 y-scale)))) - x)) - pointlist)) - ;; a path must begin with a `moveto' - (prepend-origin (apply list (cons 'moveto origin) path)) - ;; if this path is connected, add closepath to the end - (final-path (if connect - (append prepend-origin (list 'closepath)) - prepend-origin)) - (command-list (fold-right append '() final-path))) - (ly:make-stencil - `(path ,thickness - `(,@',command-list) - 'round - 'round - ,(if fill #t #f)) - (coord-translate + (boundlist (path-min-max origin pointlist)) + ;; modify pointlist to scale the coordinates + (path (map (lambda (x) + (apply + (if (= 6 (length x)) + (lambda (x1 x2 x3 x4 x5 x6) + (list 'curveto + (* x1 x-scale) + (* x2 y-scale) + (* x3 x-scale) + (* x4 y-scale) + (* x5 x-scale) + (* x6 y-scale))) + (lambda (x1 x2) + (list 'lineto + (* x1 x-scale) + (* x2 y-scale)))) + x)) + pointlist)) + ;; a path must begin with a `moveto' + (prepend-origin (apply list (cons 'moveto origin) path)) + ;; if this path is connected, add closepath to the end + (final-path (if connect + (append prepend-origin (list 'closepath)) + prepend-origin)) + (command-list (fold-right append '() final-path))) + (ly:make-stencil + `(path ,thickness + `(,@',command-list) + 'round + 'round + ,(if fill #t #f)) + (coord-translate ((if (< x-scale 0) reverse-interval identity) - (cons (* x-scale (list-ref boundlist 0)) - (* x-scale (list-ref boundlist 1)))) - `(,(/ thickness -2) . ,(/ thickness 2))) - (coord-translate + (cons (* x-scale (list-ref boundlist 0)) + (* x-scale (list-ref boundlist 1)))) + `(,(/ thickness -2) . ,(/ thickness 2))) + (coord-translate ((if (< y-scale 0) reverse-interval identity) - (cons (* y-scale (list-ref boundlist 2)) - (* y-scale (list-ref boundlist 3)))) - `(,(/ thickness -2) . ,(/ thickness 2)))))) + (cons (* y-scale (list-ref boundlist 2)) + (* y-scale (list-ref boundlist 3)))) + `(,(/ thickness -2) . ,(/ thickness 2)))))) (define-public (make-ellipse-stencil x-radius y-radius thickness fill) "Make an ellipse of x@tie{}radius @var{x-radius}, y@tie{}radius @@ -484,17 +484,17 @@ respectively." ((x-out-radius (+ x-radius (/ thickness 2.0))) (y-out-radius (+ y-radius (/ thickness 2.0))) ) - (ly:make-stencil - (list 'ellipse x-radius y-radius thickness fill) - (cons (- x-out-radius) x-out-radius) - (cons (- y-out-radius) y-out-radius)))) + (ly:make-stencil + (list 'ellipse x-radius y-radius thickness fill) + (cons (- x-out-radius) x-out-radius) + (cons (- y-out-radius) y-out-radius)))) (define-public (box-grob-stencil grob) "Make a box of exactly the extents of the grob. The box precisely encloses the contents." (let* ((xext (ly:grob-extent grob grob 0)) - (yext (ly:grob-extent grob grob 1)) - (thick 0.01)) + (yext (ly:grob-extent grob grob 1)) + (thick 0.01)) (ly:stencil-add (make-filled-box-stencil xext (cons (- (car yext) thick) (car yext))) @@ -506,10 +506,10 @@ encloses the contents." (define-public (box-stencil stencil thickness padding) "Add a box around @var{stencil}, producing a new stencil." (let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding)) - (y-ext (interval-widen (ly:stencil-extent stencil 1) padding)) - (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext)) - (x-rule (make-filled-box-stencil - (interval-widen x-ext thickness) (cons 0 thickness)))) + (y-ext (interval-widen (ly:stencil-extent stencil 1) padding)) + (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext)) + (x-rule (make-filled-box-stencil + (interval-widen x-ext thickness) (cons 0 thickness)))) (set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding)) (set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding)) (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0)) @@ -519,74 +519,74 @@ encloses the contents." (define-public (circle-stencil stencil thickness padding) "Add a circle around @var{stencil}, producing a new stencil." (let* ((x-ext (ly:stencil-extent stencil X)) - (y-ext (ly:stencil-extent stencil Y)) - (diameter (max (interval-length x-ext) + (y-ext (ly:stencil-extent stencil Y)) + (diameter (max (interval-length x-ext) (interval-length y-ext))) - (radius (+ (/ diameter 2) padding thickness)) - (circle (make-circle-stencil radius thickness #f))) + (radius (+ (/ diameter 2) padding thickness)) + (circle (make-circle-stencil radius thickness #f))) (ly:stencil-add stencil (ly:stencil-translate circle - (cons - (interval-center x-ext) - (interval-center y-ext)))))) + (cons + (interval-center x-ext) + (interval-center y-ext)))))) (define-public (oval-stencil stencil thickness x-padding y-padding) "Add an oval around @code{stencil}, padded by the padding pair, producing a new stencil." (let* ((x-ext (ly:stencil-extent stencil X)) - (y-ext (ly:stencil-extent stencil Y)) + (y-ext (ly:stencil-extent stencil Y)) (x-length (+ (interval-length x-ext) x-padding thickness)) (y-length (+ (interval-length y-ext) y-padding thickness)) (x-radius (* 0.707 x-length) ) (y-radius (* 0.707 y-length) ) - (oval (make-oval-stencil x-radius y-radius thickness #f))) + (oval (make-oval-stencil x-radius y-radius thickness #f))) (ly:stencil-add stencil (ly:stencil-translate oval - (cons - (interval-center x-ext) - (interval-center y-ext)))))) + (cons + (interval-center x-ext) + (interval-center y-ext)))))) (define-public (ellipse-stencil stencil thickness x-padding y-padding) "Add an ellipse around @var{stencil}, padded by the padding pair, producing a new stencil." (let* ((x-ext (ly:stencil-extent stencil X)) - (y-ext (ly:stencil-extent stencil Y)) + (y-ext (ly:stencil-extent stencil Y)) (x-length (+ (interval-length x-ext) x-padding thickness)) (y-length (+ (interval-length y-ext) y-padding thickness)) ;; (aspect-ratio (/ x-length y-length)) (x-radius (* 0.707 x-length) ) (y-radius (* 0.707 y-length) ) - ;; (diameter (max (- (cdr x-ext) (car x-ext)) - ;; (- (cdr y-ext) (car y-ext)))) - ;; radius (+ (/ diameter 2) padding thickness)) - (ellipse (make-ellipse-stencil x-radius y-radius thickness #f))) + ;; (diameter (max (- (cdr x-ext) (car x-ext)) + ;; (- (cdr y-ext) (car y-ext)))) + ;; radius (+ (/ diameter 2) padding thickness)) + (ellipse (make-ellipse-stencil x-radius y-radius thickness #f))) (ly:stencil-add stencil (ly:stencil-translate ellipse - (cons - (interval-center x-ext) - (interval-center y-ext)))))) + (cons + (interval-center x-ext) + (interval-center y-ext)))))) (define-public (rounded-box-stencil stencil thickness padding blot) - "Add a rounded box around @var{stencil}, producing a new stencil." + "Add a rounded box around @var{stencil}, producing a new stencil." (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding)) - (yext (interval-widen (ly:stencil-extent stencil 1) padding)) - (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext)))) - (ideal-blot (min blot (/ min-ext 2))) - (ideal-thickness (min thickness (/ min-ext 2))) - (outer (ly:round-filled-box - (interval-widen xext ideal-thickness) - (interval-widen yext ideal-thickness) - ideal-blot)) - (inner (ly:make-stencil (list 'color (x11-color 'white) - (ly:stencil-expr (ly:round-filled-box - xext yext (- ideal-blot ideal-thickness))))))) + (yext (interval-widen (ly:stencil-extent stencil 1) padding)) + (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext)))) + (ideal-blot (min blot (/ min-ext 2))) + (ideal-thickness (min thickness (/ min-ext 2))) + (outer (ly:round-filled-box + (interval-widen xext ideal-thickness) + (interval-widen yext ideal-thickness) + ideal-blot)) + (inner (ly:make-stencil (list 'color (x11-color 'white) + (ly:stencil-expr (ly:round-filled-box + xext yext (- ideal-blot ideal-thickness))))))) (set! stencil (ly:stencil-add outer inner)) stencil)) @@ -605,7 +605,7 @@ producing a new stencil." (ly:stencil-add (stencil-with-color (ly:round-filled-box x-ext y-ext 0.0) - white) + white) stencil) )) @@ -614,63 +614,63 @@ producing a new stencil." with optional arrows of @code{max-size} on start and end controlled by @var{start?} and @var{end?}." (lambda (destination max-size) - (let* - ((e_x 1+0i) - (e_y 0+1i) - (distance (sqrt (+ (* (car destination) (car destination)) - (* (cdr destination) (cdr destination))))) - (size (min max-size (/ distance 3))) - (rotate (lambda (z ang) - (* (make-polar 1 ang) - z))) - (complex-to-offset (lambda (z) - (list (real-part z) (imag-part z)))) - - (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination)))) - (e_z (/ z-dest (magnitude z-dest))) - (triangle-points (list - (* size -1+0.25i) - 0 - (* size -1-0.25i))) - (p1s (map (lambda (z) - (+ z-dest (rotate z (angle z-dest)))) - triangle-points)) - (p2s (map (lambda (z) - (rotate z (angle (- z-dest)))) - triangle-points)) - (null (cons 0 0)) - (arrow-1 - (ly:make-stencil - `(polygon (quote ,(concatenate (map complex-to-offset p1s))) - 0.0 - #t) null null)) - (arrow-2 - (ly:make-stencil - `(polygon (quote ,(concatenate (map complex-to-offset p2s))) - 0.0 - #t) null null ) ) - (thickness (min (/ distance 12) 0.1)) - (shorten-line (min (/ distance 3) 0.5)) - (start (complex-to-offset (/ (* e_z shorten-line) 2))) - (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2)))) - - (line (ly:make-stencil - `(draw-line ,thickness - ,(car start) ,(cadr start) - ,(car end) ,(cadr end) - ) - (cons (min 0 (car destination)) - (min 0 (cdr destination))) - (cons (max 0 (car destination)) - (max 0 (cdr destination))))) - - (result - (ly:stencil-add + (let* + ((e_x 1+0i) + (e_y 0+1i) + (distance (sqrt (+ (* (car destination) (car destination)) + (* (cdr destination) (cdr destination))))) + (size (min max-size (/ distance 3))) + (rotate (lambda (z ang) + (* (make-polar 1 ang) + z))) + (complex-to-offset (lambda (z) + (list (real-part z) (imag-part z)))) + + (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination)))) + (e_z (/ z-dest (magnitude z-dest))) + (triangle-points (list + (* size -1+0.25i) + 0 + (* size -1-0.25i))) + (p1s (map (lambda (z) + (+ z-dest (rotate z (angle z-dest)))) + triangle-points)) + (p2s (map (lambda (z) + (rotate z (angle (- z-dest)))) + triangle-points)) + (null (cons 0 0)) + (arrow-1 + (ly:make-stencil + `(polygon (quote ,(concatenate (map complex-to-offset p1s))) + 0.0 + #t) null null)) + (arrow-2 + (ly:make-stencil + `(polygon (quote ,(concatenate (map complex-to-offset p2s))) + 0.0 + #t) null null ) ) + (thickness (min (/ distance 12) 0.1)) + (shorten-line (min (/ distance 3) 0.5)) + (start (complex-to-offset (/ (* e_z shorten-line) 2))) + (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2)))) + + (line (ly:make-stencil + `(draw-line ,thickness + ,(car start) ,(cadr start) + ,(car end) ,(cadr end) + ) + (cons (min 0 (car destination)) + (min 0 (cdr destination))) + (cons (max 0 (car destination)) + (max 0 (cdr destination))))) + + (result + (ly:stencil-add (if start? arrow-2 empty-stencil) (if end? arrow-1 empty-stencil) line))) - result))) + result))) (define-public dimension-arrows (arrow-stencil-maker #t #t)) @@ -684,20 +684,20 @@ with optional arrows of @code{max-size} on start and end controlled by (define*-public (annotate-y-interval layout name extent is-length #:key (color darkblue)) (let ((text-props (cons '((font-size . -3) - (font-family . typewriter)) - (layout-extract-page-properties layout))) - (annotation #f)) + (font-family . typewriter)) + (layout-extract-page-properties layout))) + (annotation #f)) (define (center-stencil-on-extent stil) (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER) (cons 0 (interval-center extent)))) ;; do something sensible for 0,0 intervals. (set! extent (interval-widen extent 0.001)) (if (not (interval-sane? extent)) - (set! annotation (interpret-markup - layout text-props - (make-simple-markup (simple-format #f "~a: NaN/inf" name)))) - (let ((text-stencil (interpret-markup - layout text-props + (set! annotation (interpret-markup + layout text-props + (make-simple-markup (simple-format #f "~a: NaN/inf" name)))) + (let ((text-stencil (interpret-markup + layout text-props (markup #:whiteout #:simple name))) (dim-stencil (interpret-markup layout text-props @@ -709,88 +709,88 @@ with optional arrows of @code{max-size} on start and end controlled by (ly:format "~$" (interval-length extent))) (else (ly:format "(~$,~$)" - (car extent) (cdr extent))))))) - (arrows (ly:stencil-translate-axis - (dimension-arrows (cons 0 (interval-length extent)) 1.0) - (interval-start extent) Y))) - (set! annotation + (car extent) (cdr extent))))))) + (arrows (ly:stencil-translate-axis + (dimension-arrows (cons 0 (interval-length extent)) 1.0) + (interval-start extent) Y))) + (set! annotation (center-stencil-on-extent text-stencil)) - (set! annotation - (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5)) - (set! annotation - (ly:stencil-combine-at-edge annotation X LEFT + (set! annotation + (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5)) + (set! annotation + (ly:stencil-combine-at-edge annotation X LEFT (center-stencil-on-extent dim-stencil) 0.5)) - (set! annotation - (stencil-with-color annotation color)))) + (set! annotation + (stencil-with-color annotation color)))) annotation)) ;; TODO: figure out how to annotate padding nicely ;; TODO: emphasize either padding or min-dist depending on which constraint was active (define*-public (annotate-spacing-spec layout spacing-spec start-Y-offset next-staff-Y - #:key (base-color blue)) - (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0))) - (space (get-spacing-var 'basic-distance)) - (padding (get-spacing-var 'padding)) - (min-dist (get-spacing-var 'minimum-distance)) - (contrast-color (append (cdr base-color) (list (car base-color)))) - (min-dist-blocks (<= (- start-Y-offset min-dist) next-staff-Y)) - (min-dist-color (if min-dist-blocks contrast-color base-color)) - (basic-annotation (annotate-y-interval layout - "basic-dist" - (cons (- start-Y-offset space) start-Y-offset) - #t - #:color (map (lambda (x) (* x 0.25)) base-color))) - (min-annotation (annotate-y-interval layout - "min-dist" - (cons (- start-Y-offset min-dist) start-Y-offset) - #t - #:color min-dist-color)) - (extra-annotation (annotate-y-interval layout - "extra dist" - (cons next-staff-Y (- start-Y-offset min-dist)) - #t - #:color (map (lambda (x) (* x 0.5)) min-dist-color)))) + #:key (base-color blue)) + (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0))) + (space (get-spacing-var 'basic-distance)) + (padding (get-spacing-var 'padding)) + (min-dist (get-spacing-var 'minimum-distance)) + (contrast-color (append (cdr base-color) (list (car base-color)))) + (min-dist-blocks (<= (- start-Y-offset min-dist) next-staff-Y)) + (min-dist-color (if min-dist-blocks contrast-color base-color)) + (basic-annotation (annotate-y-interval layout + "basic-dist" + (cons (- start-Y-offset space) start-Y-offset) + #t + #:color (map (lambda (x) (* x 0.25)) base-color))) + (min-annotation (annotate-y-interval layout + "min-dist" + (cons (- start-Y-offset min-dist) start-Y-offset) + #t + #:color min-dist-color)) + (extra-annotation (annotate-y-interval layout + "extra dist" + (cons next-staff-Y (- start-Y-offset min-dist)) + #t + #:color (map (lambda (x) (* x 0.5)) min-dist-color)))) (stack-stencils X RIGHT 0.0 - (list - basic-annotation - (if min-dist-blocks - min-annotation - (ly:stencil-add min-annotation extra-annotation)))))) + (list + basic-annotation + (if min-dist-blocks + min-annotation + (ly:stencil-add min-annotation extra-annotation)))))) (define-public (eps-file->stencil axis size file-name) (let* ((contents (ly:gulp-file file-name)) (bbox (get-postscript-bbox (car (string-split contents #\nul)))) (bbox-size (if (= axis X) - (- (list-ref bbox 2) (list-ref bbox 0)) - (- (list-ref bbox 3) (list-ref bbox 1)) - )) + (- (list-ref bbox 2) (list-ref bbox 0)) + (- (list-ref bbox 3) (list-ref bbox 1)) + )) (factor (if (< 0 bbox-size) - (exact->inexact (/ size bbox-size)) - 0)) + (exact->inexact (/ size bbox-size)) + 0)) (scaled-bbox - (map (lambda (x) (* factor x)) bbox)) + (map (lambda (x) (* factor x)) bbox)) ;; We need to shift the whole eps to (0,0), otherwise it will appear ;; displaced in lilypond (displacement will depend on the scaling!) (translate-string (ly:format "~a ~a translate" (- (list-ref bbox 0)) (- (list-ref bbox 1)))) (clip-rect-string (ly:format - "~a ~a ~a ~a rectclip" - (list-ref bbox 0) - (list-ref bbox 1) - (- (list-ref bbox 2) (list-ref bbox 0)) - (- (list-ref bbox 3) (list-ref bbox 1))))) + "~a ~a ~a ~a rectclip" + (list-ref bbox 0) + (list-ref bbox 1) + (- (list-ref bbox 2) (list-ref bbox 0)) + (- (list-ref bbox 3) (list-ref bbox 1))))) (if bbox - (ly:make-stencil - (list - 'embedded-ps - (string-append - (ly:format - " + (ly:make-stencil + (list + 'embedded-ps + (string-append + (ly:format + " gsave currentpoint translate BeginEPSF @@ -800,19 +800,19 @@ BeginEPSF %%BeginDocument: ~a " factor translate-string clip-rect-string - file-name - ) - contents - "%%EndDocument +file-name +) + contents + "%%EndDocument EndEPSF grestore ")) - ;; Stencil starts at (0,0), since we have shifted the eps, and its + ;; Stencil starts at (0,0), since we have shifted the eps, and its ;; size is exactly the size of the scaled bounding box - (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0))) - (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1)))) + (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0))) + (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1)))) - (ly:make-stencil "" '(0 . 0) '(0 . 0))) + (ly:make-stencil "" '(0 . 0) '(0 . 0))) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -821,12 +821,12 @@ grestore (define-public (write-system-signatures basename paper-systems count) (if (pair? paper-systems) (begin - (let* - ((outname (simple-format #f "~a-~a.signature" basename count)) ) + (let* + ((outname (simple-format #f "~a-~a.signature" basename count)) ) - (ly:message "Writing ~a" outname) - (write-system-signature outname (car paper-systems)) - (write-system-signatures basename (cdr paper-systems) (1+ count)))))) + (ly:message "Writing ~a" outname) + (write-system-signature outname (car paper-systems)) + (write-system-signatures basename (cdr paper-systems) (1+ count)))))) (use-modules (scm paper-system)) (define-public (write-system-signature filename paper-system) @@ -846,20 +846,20 @@ grestore ((float? expr) #f) ((ly:font-metric? expr) (ly:font-name expr)) ((pair? expr) (cons (strip-floats (car expr)) - (strip-floats (cdr expr)))) + (strip-floats (cdr expr)))) (else expr))) (define (fold-false-pairs expr) "Try to remove lists of #f as much as possible." (if (pair? expr) - (let* - ((first (car expr)) - (rest (fold-false-pairs (cdr expr)))) + (let* + ((first (car expr)) + (rest (fold-false-pairs (cdr expr)))) - (if first - (cons (fold-false-pairs first) rest) - rest)) - expr)) + (if first + (cons (fold-false-pairs first) rest) + rest)) + expr)) (define (raw-string expr) "escape quotes and slashes for python consumption" @@ -867,65 +867,65 @@ grestore (define (raw-pair expr) (simple-format #f "~a ~a" - (car expr) (cdr expr))) + (car expr) (cdr expr))) (define (found-grob expr) (let* - ((grob (car expr)) - (rest (cdr expr)) - (collected '()) - (cause (event-cause grob)) - (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f)) - (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '())) - - ;; todo: use stencil extent if available. - (x-ext (ly:grob-extent grob system-grob X)) - (y-ext (ly:grob-extent grob system-grob Y)) - (expression-skeleton - (if compare-expressions - (interpret-for-signature - #f (lambda (e) - (set! collected (cons e collected))) - rest) - ""))) + ((grob (car expr)) + (rest (cdr expr)) + (collected '()) + (cause (event-cause grob)) + (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f)) + (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '())) + + ;; todo: use stencil extent if available. + (x-ext (ly:grob-extent grob system-grob X)) + (y-ext (ly:grob-extent grob system-grob Y)) + (expression-skeleton + (if compare-expressions + (interpret-for-signature + #f (lambda (e) + (set! collected (cons e collected))) + rest) + ""))) (simple-format output - "~a@~a@~a@~a@~a\n" - (cdr (assq 'name (ly:grob-property grob 'meta) )) - (raw-string location) - (raw-pair (if (interval-empty? x-ext) '(1 . -1) x-ext)) - (raw-pair (if (interval-empty? y-ext) '(1 . -1) y-ext)) - (raw-string collected)) + "~a@~a@~a@~a@~a\n" + (cdr (assq 'name (ly:grob-property grob 'meta) )) + (raw-string location) + (raw-pair (if (interval-empty? x-ext) '(1 . -1) x-ext)) + (raw-pair (if (interval-empty? y-ext) '(1 . -1) y-ext)) + (raw-string collected)) )) (define (interpret-for-signature escape collect expr) (define (interpret expr) (let* - ((head (if (pair? expr) - (car expr) - #f))) - - (cond - ((eq? head 'grob-cause) (escape (cdr expr))) - ((eq? head 'color) (interpret (caddr expr))) - ((eq? head 'rotate-stencil) (interpret (caddr expr))) - ((eq? head 'translate-stencil) (interpret (caddr expr))) - ((eq? head 'combine-stencil) - (for-each (lambda (e) (interpret e)) (cdr expr))) - (else - (collect (fold-false-pairs (strip-floats expr)))) - - ))) + ((head (if (pair? expr) + (car expr) + #f))) + + (cond + ((eq? head 'grob-cause) (escape (cdr expr))) + ((eq? head 'color) (interpret (caddr expr))) + ((eq? head 'rotate-stencil) (interpret (caddr expr))) + ((eq? head 'translate-stencil) (interpret (caddr expr))) + ((eq? head 'combine-stencil) + (for-each (lambda (e) (interpret e)) (cdr expr))) + (else + (collect (fold-false-pairs (strip-floats expr)))) + + ))) (interpret expr)) (if (ly:grob? system-grob) (begin - (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version)) - output) - (interpret-for-signature found-grob (lambda (x) #f) - (ly:stencil-expr - (paper-system-stencil paper-system))))) + (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version)) + output) + (interpret-for-signature found-grob (lambda (x) #f) + (ly:stencil-expr + (paper-system-stencil paper-system))))) ;; should be superfluous, but leaking "too many open files"? (close-port output)) diff --git a/scm/tablature.scm b/scm/tablature.scm index 3304e24af7..d62f0aa017 100644 --- a/scm/tablature.scm +++ b/scm/tablature.scm @@ -42,7 +42,7 @@ ;; define sans serif-style tab-Clefs as a markup: (define-markup-command (customTabClef - layout props num-strings staff-space) + layout props num-strings staff-space) (integer? number?) #:category music "Draw a tab clef sans-serif style." @@ -67,8 +67,8 @@ ;; if it is "moderntab", we'll draw it (let* ((staff-symbol (ly:grob-object grob 'staff-symbol)) (line-count (if (ly:grob? staff-symbol) - (ly:grob-property staff-symbol 'line-count) - 0)) + (ly:grob-property staff-symbol 'line-count) + 0)) (staff-space (ly:staff-symbol-staff-space grob))) (grob-interpret-markup grob (make-customTabClef-markup line-count @@ -142,10 +142,10 @@ ;; tab note head is visible (if tab-note-head-parenthesized (begin - (ly:grob-set-property! tied-tab-note-head 'display-cautionary #t) + (ly:grob-set-property! tied-tab-note-head 'display-cautionary #t) (ly:grob-set-property! tied-tab-note-head 'stencil tab-note-head::print))) ;; tab note head is invisible - (ly:grob-set-property! tied-tab-note-head 'transparent #t))) + (ly:grob-set-property! tied-tab-note-head 'transparent #t))) ;; tie is not split (ly:grob-set-property! tied-tab-note-head 'transparent #t))))) @@ -169,14 +169,14 @@ (tab-note-head-visible (assoc-get 'note-head-visible repeat-tied-properties #t)) (tab-note-head-parenthesized (assoc-get 'parenthesize repeat-tied-properties #t))) - (if tab-note-head-visible - ;; tab note head is visible - (if tab-note-head-parenthesized - (begin - (ly:grob-set-property! tied-tab-note-head 'display-cautionary #t) - (ly:grob-set-property! tied-tab-note-head 'stencil tab-note-head::print))) - ;; tab note head is invisible - (ly:grob-set-property! tied-tab-note-head 'transparent #t)))))) + (if tab-note-head-visible + ;; tab note head is visible + (if tab-note-head-parenthesized + (begin + (ly:grob-set-property! tied-tab-note-head 'display-cautionary #t) + (ly:grob-set-property! tied-tab-note-head 'stencil tab-note-head::print))) + ;; tab note head is invisible + (ly:grob-set-property! tied-tab-note-head 'transparent #t)))))) ;; the slurs should not be too far apart from the corresponding fret number, so ;; we move the slur towards the TabNoteHeads; moreover, if the left fret number is @@ -196,7 +196,7 @@ (* staff-space (ly:grob-property grob 'direction) 0.35)))) - control-points))) + control-points))) (ly:grob-set-property! grob 'control-points new-control-points) (ly:slur::print grob))) @@ -231,48 +231,48 @@ (define (is-harmonic? grob) (let ((arts (ly:event-property (event-cause grob) 'articulations))) (or (pair? (filter (lambda (a) - (ly:in-event-class? a 'harmonic-event)) - arts)) - (eq? (ly:grob-property grob 'style) 'harmonic)))) + (ly:in-event-class? a 'harmonic-event)) + arts)) + (eq? (ly:grob-property grob 'style) 'harmonic)))) (let* ((cautionary (ly:grob-property grob 'display-cautionary #f)) - (details (ly:grob-property grob 'details '())) - (harmonic-props (assoc-get 'harmonic-properties details '())) - (harmonic-angularity (assoc-get 'angularity harmonic-props 2)) - (harmonic-half-thick (assoc-get 'half-thickness harmonic-props 0.075)) - (harmonic-padding (assoc-get 'padding harmonic-props 0)) - (harmonic-proc (assoc-get 'procedure harmonic-props parenthesize-stencil)) - (harmonic-width (assoc-get 'width harmonic-props 0.25)) - (cautionary-props (assoc-get 'cautionary-properties details '())) - (cautionary-angularity (assoc-get 'angularity cautionary-props 2)) - (cautionary-half-thick (assoc-get 'half-thickness cautionary-props 0.075)) - (cautionary-padding (assoc-get 'padding cautionary-props 0)) - (cautionary-proc (assoc-get 'procedure cautionary-props parenthesize-stencil)) - (cautionary-width (assoc-get 'width cautionary-props 0.25)) + (details (ly:grob-property grob 'details '())) + (harmonic-props (assoc-get 'harmonic-properties details '())) + (harmonic-angularity (assoc-get 'angularity harmonic-props 2)) + (harmonic-half-thick (assoc-get 'half-thickness harmonic-props 0.075)) + (harmonic-padding (assoc-get 'padding harmonic-props 0)) + (harmonic-proc (assoc-get 'procedure harmonic-props parenthesize-stencil)) + (harmonic-width (assoc-get 'width harmonic-props 0.25)) + (cautionary-props (assoc-get 'cautionary-properties details '())) + (cautionary-angularity (assoc-get 'angularity cautionary-props 2)) + (cautionary-half-thick (assoc-get 'half-thickness cautionary-props 0.075)) + (cautionary-padding (assoc-get 'padding cautionary-props 0)) + (cautionary-proc (assoc-get 'procedure cautionary-props parenthesize-stencil)) + (cautionary-width (assoc-get 'width cautionary-props 0.25)) (output-grob (ly:text-interface::print grob)) - (ref-grob (grob-interpret-markup grob "8")) - (offset-factor (assoc-get 'head-offset details 3/5)) - (column-offset (* offset-factor - (interval-length - (ly:stencil-extent - (grob-interpret-markup grob "8") - X))))) + (ref-grob (grob-interpret-markup grob "8")) + (offset-factor (assoc-get 'head-offset details 3/5)) + (column-offset (* offset-factor + (interval-length + (ly:stencil-extent + (grob-interpret-markup grob "8") + X))))) (if (is-harmonic? grob) (set! output-grob (harmonic-proc output-grob - harmonic-half-thick - harmonic-width - harmonic-angularity - harmonic-padding))) + harmonic-half-thick + harmonic-width + harmonic-angularity + harmonic-padding))) (if cautionary (set! output-grob (cautionary-proc output-grob - cautionary-half-thick - cautionary-width - cautionary-angularity - cautionary-padding))) + cautionary-half-thick + cautionary-width + cautionary-angularity + cautionary-padding))) (ly:stencil-translate-axis (centered-stencil output-grob) - column-offset - X))) + column-offset + X))) ;; Harmonic definitions @@ -290,13 +290,13 @@ ;; According to the arithmetic sum, the position of m/n is at 1/2*(n-2)(n-1)+(m-1) ;; if we start counting from zero (vector 12 - 7 19 - 5 12 24 - 4 9 16 28 - 3 7 12 19 31 - 2.7 5.8 9.7 14.7 21.7 33.7 - 2.3 5 8 12 17 24 36 - 2 4.4 7 10 14 19 26 38 )) + 7 19 + 5 12 24 + 4 9 16 28 + 3 7 12 19 31 + 2.7 5.8 9.7 14.7 21.7 33.7 + 2.3 5 8 12 17 24 36 + 2 4.4 7 10 14 19 26 38 )) (define partial-pitch (vector '(0 0 0) @@ -332,25 +332,25 @@ (- den 1) 1/2) nom -1))) - (number->string (vector-ref node-positions index)))) + (number->string (vector-ref node-positions index)))) (define-public (ratio->pitch ratio) "Calculate a pitch given @var{ratio} for the harmonic." (let* ((partial (1- (denominator ratio))) (pitch (vector-ref partial-pitch partial))) - (ly:make-pitch (first pitch) - (second pitch) - (third pitch)))) + (ly:make-pitch (first pitch) + (second pitch) + (third pitch)))) (define-public (fret->pitch fret) "Calculate a pitch given @var{fret} for the harmonic." (let* ((partial (assoc-get fret fret-partials 0)) (pitch (vector-ref partial-pitch partial))) - (ly:make-pitch (first pitch) - (second pitch) - (third pitch)))) + (ly:make-pitch (first pitch) + (second pitch) + (third pitch)))) (define-public (calc-harmonic-pitch pitch music) "Calculate the harmonic pitches in @var{music} given @@ -359,29 +359,29 @@ (e (ly:music-property music 'element)) (p (ly:music-property music 'pitch))) (cond - ((pair? es) - (ly:music-set-property! music 'elements - (map (lambda (x) (calc-harmonic-pitch pitch x)) es))) - ((ly:music? e) - (ly:music-set-property! music 'element (calc-harmonic-pitch pitch e))) - ((ly:pitch? p) - (begin - (set! p (ly:pitch-transpose p pitch)) - (ly:music-set-property! music 'pitch p)))) + ((pair? es) + (ly:music-set-property! music 'elements + (map (lambda (x) (calc-harmonic-pitch pitch x)) es))) + ((ly:music? e) + (ly:music-set-property! music 'element (calc-harmonic-pitch pitch e))) + ((ly:pitch? p) + (begin + (set! p (ly:pitch-transpose p pitch)) + (ly:music-set-property! music 'pitch p)))) music)) (define-public (make-harmonic mus) "Convert music variable @var{mus} to harmonics." (let ((elts (ly:music-property mus 'elements)) (elt (ly:music-property mus 'element))) - (cond - ((pair? elts) - (map make-harmonic elts)) - ((ly:music? elt) - (make-harmonic elt)) - ((music-is-of-type? mus 'note-event) - (set! (ly:music-property mus 'articulations) - (append - (ly:music-property mus 'articulations) - (list (make-music 'HarmonicEvent)))))) - mus)) + (cond + ((pair? elts) + (map make-harmonic elts)) + ((ly:music? elt) + (make-harmonic elt)) + ((music-is-of-type? mus 'note-event) + (set! (ly:music-property mus 'articulations) + (append + (ly:music-property mus 'articulations) + (list (make-music 'HarmonicEvent)))))) + mus)) diff --git a/scm/text.scm b/scm/text.scm index ee399f94ba..1454105912 100644 --- a/scm/text.scm +++ b/scm/text.scm @@ -25,5 +25,5 @@ (define-public (internal-add-text-replacements props alist) (let* ((dummy-replacements (chain-assoc-get 'replacement-alist props '())) (new-replacements - (append dummy-replacements alist))) + (append dummy-replacements alist))) (prepend-alist-chain 'replacement-alist new-replacements props))) diff --git a/scm/time-signature-settings.scm b/scm/time-signature-settings.scm index d9e62fe1b8..e171149ec4 100644 --- a/scm/time-signature-settings.scm +++ b/scm/time-signature-settings.scm @@ -71,7 +71,7 @@ ;; in 2/2 time: ;; use defaults, but end beams with 32nd notes each 1 4 beat ((2 . 2) . - ((beamExceptions . ((end . (((1 . 32) . (8 8 8 8)))))))) + ((beamExceptions . ((end . (((1 . 32) . (8 8 8 8)))))))) ;; in 2/4, 2/8 and 2/16 time: ;; use defaults, so no entries are necessary @@ -80,7 +80,7 @@ ;; use defaults, but end beams with 32nd notes and higher each 1 4 beat ((3 . 2) . - ((beamExceptions . ((end . (((1 . 32) . (8 8 8 8 8 8)))))))) + ((beamExceptions . ((end . (((1 . 32) . (8 8 8 8 8 8)))))))) ;; in 3 4 time: ;; use defaults, but combine all beats into a unit if possible @@ -89,8 +89,8 @@ ;; in order to avoid beaming every beam type for the entire measure, we set ;; triplets back to every beat. ((3 . 4) . - ((beamExceptions . ((end . (((1 . 8) . (6)) ;1/8 note whole measure - ((1 . 12) . (3 3 3)))))))) ;Anything shorter by beat + ((beamExceptions . ((end . (((1 . 8) . (6)) ;1/8 note whole measure + ((1 . 12) . (3 3 3)))))))) ;Anything shorter by beat ;; in 3 8 time: ;; beam entire measure together @@ -102,7 +102,7 @@ ;; in 4 2 time: ;; use defaults, but end beams with 16th notes or finer each 1 4 beat ((4 . 2) . - ((beamExceptions . ((end . (((1 . 16) . (4 4 4 4 4 4 4 4)))))))) + ((beamExceptions . ((end . (((1 . 16) . (4 4 4 4 4 4 4 4)))))))) ;; in 4 4 (common) time: ;; use defaults, but combine beats 1,2 and 3,4 if only 8th notes @@ -110,8 +110,8 @@ ;; ly/engraver-init.ly where the default time signature is set ;; are set ((4 . 4) . - ((beamExceptions . ((end . (((1 . 8) . (4 4)) ; 1/8 notes half measure - ((1 . 12) . (3 3 3 3)))))))) ;Anything shorter by beat + ((beamExceptions . ((end . (((1 . 8) . (4 4)) ; 1/8 notes half measure + ((1 . 12) . (3 3 3 3)))))))) ;Anything shorter by beat ;; in 4/8 time: ;; combine beats 1 and 2, so beam in 2 @@ -123,7 +123,7 @@ ;; in 6 4 time: ;; use defaults, but end beams with 32nd or finer each 1/4 beat ((6 . 4) . - ((beamExceptions . ((end . (((1 . 16) . (4 4 4 4 4 4)))))))) + ((beamExceptions . ((end . (((1 . 16) . (4 4 4 4 4 4)))))))) ;; in 6 8 time: ;; use defaults, so no entries necessary @@ -134,7 +134,7 @@ ;; in 9 4 time: ;; use defaults, but end beams with 32nd or finer each 1 4 beat ((9 . 4) . - ((beamExceptions . ((end . (((1 . 32) . (8 8 8 8 8 8 8 8)))))))) + ((beamExceptions . ((end . (((1 . 32) . (8 8 8 8 8 8 8 8)))))))) ;; in 9 8 time ;; use defaults, so no entries necessary @@ -145,7 +145,7 @@ ;; in 12 4 time: ;; use defaults, but end beams with 32nd or finer notes each 1 4 beat ((12 . 4) . - ((beamExceptions . ((end . (((1 . 32) . (8 8 8 8 8 8 8 8 8 8 8 8)))))))) + ((beamExceptions . ((end . (((1 . 32) . (8 8 8 8 8 8 8 8 8 8 8 8)))))))) ;; in 12 8 time: ;; use defaults, so no entries necessary @@ -156,12 +156,12 @@ ;; in 5 8 time: ;; default: group (3 2) ((5 . 8) . - ((beatStructure . (3 2)))) + ((beatStructure . (3 2)))) ;; in 8 8 time: ;; default: group (3 3 2) ((8 . 8) . - ((beatStructure . (3 3 2)))) + ((beatStructure . (3 3 2)))) )) ; end of alist definition @@ -173,28 +173,28 @@ "Get setting @code{my-symbol} for @code{time-signature} from @code{time-signature-settings}." (let ((my-time-signature-settings - (assoc-get time-signature time-signature-settings '()))) - (assoc-get my-symbol my-time-signature-settings '()))) + (assoc-get time-signature time-signature-settings '()))) + (assoc-get my-symbol my-time-signature-settings '()))) (define-public (make-setting base-fraction beat-structure beam-exceptions) (list - (cons 'baseMoment (if (pair? base-fraction) - (/ (car base-fraction) (cdr base-fraction)) - base-fraction)) - (cons 'beatStructure beat-structure) - (cons 'beamExceptions beam-exceptions))) + (cons 'baseMoment (if (pair? base-fraction) + (/ (car base-fraction) (cdr base-fraction)) + base-fraction)) + (cons 'beatStructure beat-structure) + (cons 'beamExceptions beam-exceptions))) (define-public (base-length time-signature time-signature-settings) "Get @code{baseMoment} rational value for @var{time-signature} from @var{time-signature-settings}." - (let ((return-value (get-setting 'baseMoment - time-signature - time-signature-settings))) - (if (null? return-value) - (/ (cdr time-signature)) - return-value))) + (let ((return-value (get-setting 'baseMoment + time-signature + time-signature-settings))) + (if (null? return-value) + (/ (cdr time-signature)) + return-value))) (define-public (beat-structure base-length time-signature time-signature-settings) "Get @code{beatStructure} value in @var{base-length} units @@ -223,7 +223,7 @@ for @var{time-signature} from @var{time-signature-settings}." (define-public (beam-exceptions time-signature time-signature-settings) "Get @code{beamExceptions} value for @var{time-signature} from @var{time-signature-settings}." - (get-setting 'beamExceptions time-signature time-signature-settings)) + (get-setting 'beamExceptions time-signature time-signature-settings)) ;;; Functions for overriding time-signature settings @@ -233,10 +233,10 @@ for @var{time-signature} from @var{time-signature-settings}." "Like the C++ code that executes \\override, but without type checking." (begin - (ly:context-set-property! - context - property - (cons (cons setting value) (ly:context-property context property))))) + (ly:context-set-property! + context + property + (cons (cons setting value) (ly:context-property context property))))) (define (revert-property-setting context property setting) "Like the C++ code that executes \revert, but without type @@ -246,50 +246,50 @@ checking." "Count the number of entries in alist with a key of ENTRY-KEY." (cond - ((null? alist) 0) - ((equal? (caar alist) entry-key) - (+ 1 (entry-count (cdr alist) entry-key))) - (else (entry-count (cdr alist) entry-key)))) + ((null? alist) 0) + ((equal? (caar alist) entry-key) + (+ 1 (entry-count (cdr alist) entry-key))) + (else (entry-count (cdr alist) entry-key)))) (define (revert-member alist entry-key) "Return ALIST, with the first entry having a key of ENTRY-KEY removed. ALIST is not modified, instead a fresh copy of the list-head is made." (cond - ((null? alist) '()) - ((equal? (caar alist) entry-key) (cdr alist)) - (else (cons (car alist) - (revert-member (cdr alist) entry-key))))) + ((null? alist) '()) + ((equal? (caar alist) entry-key) (cdr alist)) + (else (cons (car alist) + (revert-member (cdr alist) entry-key))))) ;; body of revert-property-setting (let ((current-value (ly:context-property context property))) (if (> (entry-count current-value setting) 0) (ly:context-set-property! - context - property - (revert-member current-value setting))))) + context + property + (revert-member current-value setting))))) (define-public (override-time-signature-setting time-signature setting) "Override the time signature settings for the context in @var{time-signature}, with the new setting alist @var{setting}." - (context-spec-music - (make-apply-context - (lambda (c) (override-property-setting - c - 'timeSignatureSettings - time-signature - setting))) - 'Timing)) + (context-spec-music + (make-apply-context + (lambda (c) (override-property-setting + c + 'timeSignatureSettings + time-signature + setting))) + 'Timing)) (define-public (revert-time-signature-setting time-signature) (context-spec-music - (make-apply-context - (lambda (c) - (revert-property-setting - c - 'timeSignatureSettings - time-signature))) - 'Timing)) + (make-apply-context + (lambda (c) + (revert-property-setting + c + 'timeSignatureSettings + time-signature))) + 'Timing)) @@ -312,24 +312,24 @@ a fresh copy of the list-head is made." (den (car revargs)) (nums (reverse (cdr revargs)))) (make-override-markup '(baseline-skip . 0) - (make-number-markup - (make-left-column-markup (list - (make-center-column-markup (list - (make-line-markup (insert-markups nums "+")) - den)))))))) + (make-number-markup + (make-left-column-markup (list + (make-center-column-markup (list + (make-line-markup (insert-markups nums "+")) + den)))))))) (define (format-complex-compound-time time-sig) (make-override-markup '(baseline-skip . 0) - (make-number-markup - (make-line-markup - (insert-markups (map format-time-fraction time-sig) - (make-vcenter-markup "+")))))) + (make-number-markup + (make-line-markup + (insert-markups (map format-time-fraction time-sig) + (make-vcenter-markup "+")))))) (define-public (format-compound-time time-sig) (cond - ((not (pair? time-sig)) (null-markup)) - ((pair? (car time-sig)) (format-complex-compound-time time-sig)) - (else (format-time-fraction time-sig)))) + ((not (pair? time-sig)) (null-markup)) + ((pair? (car time-sig)) (format-complex-compound-time time-sig)) + (else (format-time-fraction time-sig)))) ;;;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -350,9 +350,9 @@ a fresh copy of the list-head is made." (define-public (calculate-compound-measure-length time-sig) (cond - ((not (pair? time-sig)) (ly:make-moment 4 4)) - ((pair? (car time-sig)) (calculate-complex-compound-time time-sig)) - (else (calculate-time-fraction time-sig)))) + ((not (pair? time-sig)) (ly:make-moment 4 4)) + ((pair? (car time-sig)) (calculate-complex-compound-time time-sig)) + (else (calculate-time-fraction time-sig)))) ;;;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -363,10 +363,10 @@ a fresh copy of the list-head is made." (define-public (calculate-compound-base-beat time-sig) (ly:make-moment 1 - (cond - ((not (pair? time-sig)) 4) - ((pair? (car time-sig)) (calculate-compound-base-beat-full time-sig)) - (else (calculate-compound-base-beat-full (list time-sig)))))) + (cond + ((not (pair? time-sig)) 4) + ((pair? (car time-sig)) (calculate-compound-base-beat-full time-sig)) + (else (calculate-compound-base-beat-full (list time-sig)))))) ;;;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -386,6 +386,6 @@ a fresh copy of the list-head is made." (define-public (calculate-compound-beat-grouping time-sig) (cond - ((not (pair? time-sig)) '(2 . 2)) - ((pair? (car time-sig)) (beat-grouping-internal time-sig)) - (else (beat-grouping-internal (list time-sig))))) + ((not (pair? time-sig)) '(2 . 2)) + ((pair? (car time-sig)) (beat-grouping-internal time-sig)) + (else (beat-grouping-internal (list time-sig))))) diff --git a/scm/titling.scm b/scm/titling.scm index 7118fb1a06..b5f8b1bb8a 100644 --- a/scm/titling.scm +++ b/scm/titling.scm @@ -18,8 +18,8 @@ (define-public (layout-extract-page-properties layout) (list (append `((line-width . ,(ly:paper-get-number - layout 'line-width))) - (ly:output-def-lookup layout 'text-font-defaults)))) + layout 'line-width))) + (ly:output-def-lookup layout 'text-font-defaults)))) ;;;;;;;;;;;;;;;;;; @@ -29,46 +29,46 @@ and interpret them as markup. The @var{props} argument will include variables set in @var{scopes} and @code{page:is-bookpart-last-page}, @code{page:is-last-bookpart}, @code{page:page-number-string}, and -@code{page:page-number}." +@code{page:page-number}." (define (get sym) (ly:output-def-lookup layout sym)) (define (interpret-in-page-env potential-markup) (if (markup? potential-markup) - (let* ((alists (map ly:module->alist scopes)) - (prefixed-alists - (map (lambda (alist) - (map (lambda (entry) - (cons - (string->symbol - (string-append - "header:" - (symbol->string (car entry)))) - (cdr entry))) - alist)) - alists)) - (pgnum-alist - (list - (cons 'header:tagline - (ly:modules-lookup scopes 'tagline - (ly:output-def-lookup layout 'tagline))) - (cons 'page:is-last-bookpart is-last-bookpart) - (cons 'page:is-bookpart-last-page is-bookpart-last-page) - (cons 'page:page-number-string - (number->string page-number)) - (cons 'page:page-number page-number))) - (props (append - (list pgnum-alist) - prefixed-alists - (layout-extract-page-properties layout)))) - (interpret-markup layout props potential-markup)) + (let* ((alists (map ly:module->alist scopes)) + (prefixed-alists + (map (lambda (alist) + (map (lambda (entry) + (cons + (string->symbol + (string-append + "header:" + (symbol->string (car entry)))) + (cdr entry))) + alist)) + alists)) + (pgnum-alist + (list + (cons 'header:tagline + (ly:modules-lookup scopes 'tagline + (ly:output-def-lookup layout 'tagline))) + (cons 'page:is-last-bookpart is-last-bookpart) + (cons 'page:is-bookpart-last-page is-bookpart-last-page) + (cons 'page:page-number-string + (number->string page-number)) + (cons 'page:page-number page-number))) + (props (append + (list pgnum-alist) + prefixed-alists + (layout-extract-page-properties layout)))) + (interpret-markup layout props potential-markup)) - empty-stencil)) + empty-stencil)) (interpret-in-page-env (if (and (even? page-number) - (markup? (get what-even))) + (markup? (get what-even))) (get what-even) (get what-odd)))) @@ -76,28 +76,28 @@ variables set in @var{scopes} and @code{page:is-bookpart-last-page}, "Read variables @var{what} from @var{scopes}, and interpret it as markup. The @var{props} argument will include variables set in @var{scopes} (prefixed with `header:'." - + (define (get sym) (let ((x (ly:modules-lookup scopes sym))) (if (markup? x) x #f))) (let* ((alists (map ly:module->alist scopes)) - (prefixed-alist - (map (lambda (alist) - (map (lambda (entry) - (cons - (string->symbol - (string-append - "header:" - (symbol->string (car entry)))) - (cdr entry))) - alist)) - alists)) - (props (append prefixed-alist - (layout-extract-page-properties layout))) + (prefixed-alist + (map (lambda (alist) + (map (lambda (entry) + (cons + (string->symbol + (string-append + "header:" + (symbol->string (car entry)))) + (cdr entry))) + alist)) + alists)) + (props (append prefixed-alist + (layout-extract-page-properties layout))) - (markup (ly:output-def-lookup layout what))) + (markup (ly:output-def-lookup layout what))) (if (markup? markup) - (interpret-markup layout props markup) + (interpret-markup layout props markup) empty-stencil))) diff --git a/scm/to-xml.scm b/scm/to-xml.scm index ea7ce7a0fc..02f918eda9 100644 --- a/scm/to-xml.scm +++ b/scm/to-xml.scm @@ -19,9 +19,9 @@ (define-module (scm to-xml)) (use-modules (ice-9 regex) - (srfi srfi-1) - (lily) - (oop goops)) + (srfi srfi-1) + (lily) + (oop goops)) " Todo: this is a quick hack; it makes more sense to define a GOOPS @@ -47,11 +47,11 @@ is then separated. (name #:init-value "" #:accessor node-name #:init-keyword #:name) (value #:init-value "" #:accessor node-value #:init-keyword #:value) (attributes #:init-value '() - #:accessor node-attributes - #:init-keyword #:attributes) + #:accessor node-attributes + #:init-keyword #:attributes) (children #:init-value '() - #:accessor node-children - #:init-keyword #:children)) + #:accessor node-children + #:init-keyword #:children)) (define node-names '((NoteEvent . note) @@ -68,10 +68,10 @@ is then separated. (string-append (if xml-name (open-tag xml-name '() '()) "") (if (equal? (node-value node) "") - (string-append - (if xml-name "\n" "") - (apply string-append (map musicxml-node->string (node-children node)))) - (node-value node)) + (string-append + (if xml-name "\n" "") + (apply string-append (map musicxml-node->string (node-children node)))) + (node-value node)) (if xml-name (close-tag xml-name) "") (if xml-name "\n" "")))) @@ -81,7 +81,7 @@ is then separated. (open-tag (node-name node) (node-attributes node) '()) (if (equal? (node-value node) "") (string-append - (apply string-append (map xml-node->string (node-children node)))) + (apply string-append (map xml-node->string (node-children node)))) (node-value node)) "\n" (close-tag (node-name node)))) @@ -96,26 +96,26 @@ is then separated. #:name 'duration ;; #:value (number->string (ash 1 (ly:duration-log d))))) #:attributes `((log . ,(ly:duration-log d)) - (dots . ,(ly:duration-dot-count d)) - (numer . ,(car (ly:duration-factor d))) - (denom . ,(cdr (ly:duration-factor d)))))) + (dots . ,(ly:duration-dot-count d)) + (numer . ,(car (ly:duration-factor d))) + (denom . ,(cdr (ly:duration-factor d)))))) (define (pitch->xml-node p) (make <xml-node> #:name 'pitch #:attributes `((octave . ,(ly:pitch-octave p)) - (notename . ,(ly:pitch-notename p)) - (alteration . ,(ly:pitch-alteration p))))) + (notename . ,(ly:pitch-notename p)) + (alteration . ,(ly:pitch-alteration p))))) (define (music->xml-node music) (let* ((name (ly:music-property music 'name)) - (e (ly:music-property music 'element)) - (es (ly:music-property music 'elements)) - (mprops (ly:music-mutable-properties music)) - (d (ly:music-property music 'duration)) - (p (ly:music-property music 'pitch)) - (ignore-props '(origin elements duration pitch element))) - + (e (ly:music-property music 'element)) + (es (ly:music-property music 'elements)) + (mprops (ly:music-mutable-properties music)) + (d (ly:music-property music 'duration)) + (p (ly:music-property music 'pitch)) + (ignore-props '(origin elements duration pitch element))) + (make <xml-node> #:name name #:children @@ -197,7 +197,7 @@ is then separated. (if (null? alist) string (re-sub (caar alist) (cdar alist) - (re-sub-alist string (cdr alist))))) + (re-sub-alist string (cdr alist))))) (define xml-entities-alist '(("\"" . """) @@ -209,17 +209,17 @@ is then separated. (define (open-tag tag attrs exceptions) (define (candidate? x) (not (memq (car x) exceptions))) - + (define (dump-attr sym-val) (let* ((sym (car sym-val)) - (val (cdr sym-val))) - + (val (cdr sym-val))) + (string-append "\n " (symbol->string sym) "=\"" (let ((s (call-with-output-string (lambda (port) (display val port))))) - (re-sub-alist s xml-entities-alist)) + (re-sub-alist s xml-entities-alist)) "\""))) (string-append @@ -236,7 +236,7 @@ is then separated. ;; dtd contains # -- This confuses tex during make doc. ;; ;; (display (dtd-header) port) - + (display (open-tag 'music '((type . score)) '()) port) (display (xml-node->string (music->xml-node music)) port) (display (close-tag 'music) port)) @@ -249,7 +249,7 @@ is then separated. ;; (display (dtd-header) port) (define duration->xml-node musicxml-duration->xml-node) - + (display (open-tag 'music '((type . score)) '()) port) (display (musicxml-node->string (music->xml-node music)) port) (display (close-tag 'music) port)) diff --git a/scm/translation-functions.scm b/scm/translation-functions.scm index 49d8768eb4..bc988ebd5a 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--2012 Han-Wen Nienhuys <hanwen@xs4all.nl> -;;;; Jan Nieuwenhuizen <janneke@gnu.org> +;;;; Jan Nieuwenhuizen <janneke@gnu.org> ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -32,7 +32,7 @@ way the transposition number is displayed." (cons "" ""))) (text (string-concatenate (list (car delim) oct (cdr delim))))) - (make-vcenter-markup text))) + (make-vcenter-markup text))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -40,55 +40,55 @@ way the transposition number is displayed." (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))) + (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))) + (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))) (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)))) @@ -107,7 +107,7 @@ way the transposition number is displayed." (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))))) @@ -123,13 +123,13 @@ way the transposition number is displayed." (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))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -137,79 +137,79 @@ way the transposition number is displayed." (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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -219,12 +219,12 @@ way the transposition number is displayed." "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))) @@ -251,21 +251,21 @@ be returned." dot placement entries." (let* ((placements (list->vector (map (lambda (x) (list 'mute x)) - (iota string-count 1))))) + (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)))))) - string-frets) + (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) (vector->list placements))) (define (placement-list->string-frets placement-list) @@ -289,12 +289,12 @@ if no string-number is present." (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 @@ -302,8 +302,8 @@ along with @var{minimum-fret}, @var{maximum-stretch}, and (define restrain-open-strings (ly:context-property context - 'restrainOpenStrings - #f)) + 'restrainOpenStrings + #f)) (define specified-frets '()) (define free-strings (iota (length tuning) 1)) @@ -320,21 +320,21 @@ along with @var{minimum-fret}, @var{maximum-stretch}, and "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))) + (finger-found #f)) + (map (lambda (art) + (let* ((num (ly:event-property art 'digit))) - (if (and (ly:in-event-class? art 'fingering-event) - (number? num) - (> num 0)) - (set! finger-found num)))) - articulations) - finger-found)) + (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)))) + (set! free-strings + (delete string free-strings)))) (define (close-enough fret) "Decide if @var{fret} is acceptable, given the already used frets." @@ -348,29 +348,29 @@ if no fingering is present." "Can @var{pitch} be played on @var{string}, given already placed notes?" (let* ((fret (calc-fret pitch string tuning))) - (and (or (and (not restrain-open-strings) - (zero? fret)) - (>= fret minimum-fret)) - (integer? 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))) - (zero? fret))) + (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) + 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) @@ -380,11 +380,11 @@ the current tuning?" (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)) + (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* ((pitches (map note-pitch notes)) @@ -392,87 +392,87 @@ the current tuning?" ;; 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: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:pitch<? (car pitch-entry-b) - (car pitch-entry-a))))) - string-fret-fingers)) ;; end of determine-frets-and-strings + (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: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:pitch<? (car pitch-entry-b) + (car pitch-entry-a))))) + string-fret-fingers)) ;; end of determine-frets-and-strings (define (get-predefined-fretboard predefined-fret-table tuning pitches) "Search through @var{predefined-fret-table} looking for a predefined @@ -482,31 +482,31 @@ chords. Returns a placement-list." (define (get-fretboard key) (let ((hash-handle - (hash-get-handle predefined-fret-table key))) - (if hash-handle - (cdr hash-handle) ; return table entry - '()))) + (hash-get-handle predefined-fret-table key))) + (if hash-handle + (cdr hash-handle) ; return table entry + '()))) ;; body of get-predefined-fretboard (let ((test-fretboard (get-fretboard (cons tuning pitches)))) (if (not (null? test-fretboard)) - test-fretboard - (let ((test-fretboard - (get-fretboard - (cons tuning (map (lambda (x) (shift-octave x 1)) pitches))))) - (if (not (null? test-fretboard)) - test-fretboard - (get-fretboard - (cons tuning (map (lambda (x) (shift-octave x -1)) - pitches)))))))) + test-fretboard + (let ((test-fretboard + (get-fretboard + (cons tuning (map (lambda (x) (shift-octave x 1)) pitches))))) + (if (not (null? test-fretboard)) + test-fretboard + (get-fretboard + (cons tuning (map (lambda (x) (shift-octave x -1)) + pitches)))))))) ;; body of determine-frets (let* ((predefined-fret-table - (ly:context-property context 'predefinedDiagramTable)) + (ly:context-property context 'predefinedDiagramTable)) (tunings (ly:context-property context 'stringTunings)) (string-count (length tunings)) (grob (if (null? rest) '() (car rest))) - (pitches (map (lambda (x) (ly:event-property x 'pitch)) notes)) + (pitches (map (lambda (x) (ly:event-property x 'pitch)) notes)) (defined-strings (map (lambda (x) (if (null? x) x @@ -529,26 +529,26 @@ chords. Returns a placement-list." tunings pitches) '()))) - (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))))) + (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))))) @@ -561,24 +561,24 @@ 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 #f "~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 @@ -588,11 +588,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 ;; @@ -601,13 +601,13 @@ 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 @@ -621,7 +621,7 @@ only ~a fret labels provided") (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))))) + (modulo-bar-number-visible n (modulo bn n))))) (define-public (first-bar-number-invisible barnum mp) (> barnum 1)) @@ -641,14 +641,14 @@ only ~a fret labels provided") (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))))) + 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 "" "(")) @@ -699,10 +699,10 @@ 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))) + `(list + ,@(map (lambda (form) + (if (pair? (car form)) + `(cons ',(caar form) (lambda ,(cdar form) ,@(cdr form))) + `(cons ',(car form) ,(loop (cdr form))))) + forms)) + forms))) diff --git a/scm/x11-color.scm b/scm/x11-color.scm index 5be7657292..f3d65b90c2 100644 --- a/scm/x11-color.scm +++ b/scm/x11-color.scm @@ -15,7 +15,7 @@ ;;;; You should have received a copy of the GNU General Public License ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>. -(define x11-color-list +(define x11-color-list '((snow 1 0.98039215686274506 0.98039215686274506) (GhostWhite 0.97254901960784312 0.97254901960784312 1) (WhiteSmoke 0.96078431372549022 0.96078431372549022 0.96078431372549022) @@ -677,32 +677,32 @@ (define (make-x11-color-handler) (let ((x11-color-table (make-hash-table 31))) - + (lambda (arg) - (let* - ((arg-sym (if (string? arg) - (if (string-index arg #\ ) - (let - ((arg-list (string-split (string-capitalize arg) #\ ))) + (let* + ((arg-sym (if (string? arg) + (if (string-index arg #\ ) + (let + ((arg-list (string-split (string-capitalize arg) #\ ))) + + (string->symbol + (let append-all ((x arg-list)) + (if (null? x) + "" + (string-append (car x) (append-all (cdr x))))))) + + (string->symbol arg)) + arg)) + + (temp (hashq-ref x11-color-table arg-sym))) + + (if temp + temp + (let* + ((temp-1 (assq-ref x11-color-list arg-sym)) + (temp (if temp-1 temp-1 '(0 0 0)))) - (string->symbol - (let append-all ((x arg-list)) - (if (null? x) - "" - (string-append (car x) (append-all (cdr x))))))) - - (string->symbol arg)) - arg)) - - (temp (hashq-ref x11-color-table arg-sym))) - - (if temp - temp - (let* - ((temp-1 (assq-ref x11-color-list arg-sym)) - (temp (if temp-1 temp-1 '(0 0 0)))) - - (hashq-create-handle! x11-color-table arg-sym temp) - temp)))))) + (hashq-create-handle! x11-color-table arg-sym temp) + temp)))))) (define-public x11-color (make-x11-color-handler)) |