X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=5bbd07ea8fae1ade4bffe1067e9d7faf6b213d69;hb=97a0169312a260933246ab224e4f8b0969871dd5;hp=23a797779d3bf0dc2632c18c7841fdae57c7ca54;hpb=2188505a75fb36893b0ec261c6bc194a201ec66e;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 23a797779d..5bbd07ea8f 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; Copyright (C) 1998--2012 Jan Nieuwenhuizen +;;;; Copyright (C) 1998--2015 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify @@ -16,10 +16,11 @@ ;;;; You should have received a copy of the GNU General Public License ;;;; along with LilyPond. If not, see . -; 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)) (use-modules (ice-9 optargs)) +(use-modules (srfi srfi-11)) ;;; ly:music-property with setter ;;; (ly:music-property my-music 'elements) @@ -28,32 +29,40 @@ ;;; ==> 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}?" (memq type (ly:music-property mus 'types))) +(define-safe-public (music-type-predicate types) + "Returns a predicate function that can be used for checking +music to have one of the types listed in @var{types}." + (if (cheap-list? types) + (lambda (m) + (any (lambda (t) (music-is-of-type? m t)) types)) + (lambda (m) (music-is-of-type? m types)))) + ;; 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,46 +70,48 @@ 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) "Filter out music expressions that do not satisfy @var{pred?}." - (define (inner-music-filter pred? music) + (define (inner-music-filter 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 inner-music-filter as))) + (filtered-e (if (ly:music? e) + (inner-music-filter e) + e)) + (filtered-es (filter ly:music? (map inner-music-filter 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)) - ;; if filtering emptied the expression, we remove it completely. + (set! (ly:music-property music 'articulations) filtered-as)) + ;; if filtering invalidated 'element, we remove the music unless + ;; there are remaining 'elements in which case we just hope and + ;; pray. (if (or (not (pred? music)) - (and (eq? filtered-es '()) (not (ly:music? e)) - (or (not (eq? es '())) - (ly:music? e)))) - (set! music '())) + (and (null? filtered-es) + (not (ly:music? filtered-e)) + (ly:music? e))) + (set! music '())) music)) - (set! music (inner-music-filter pred? music)) + (set! music (inner-music-filter 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 +119,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 +145,20 @@ For instance, "Return a keyword, eg. `#:bold', from the `proc' function, eg. #" (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)))) + (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 @@ -157,53 +168,63 @@ For instance, "Generate an expression that, once evaluated, may return an object equivalent to @var{obj}, that is, for a music expression, a @code{(make-music ...)} form." + (define (if-nonzero num) + (if (zero? num) '() (list num))) (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) - `(',(car 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))) + (markup? obj) + (markup-expression->make-markup obj)) + (;; music expression + (ly:music? obj) + `(make-music + ',(ly:music-property obj 'name) + ,@(append-map (lambda (prop) + `(',(car 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 + ,@(let ((main (ly:moment-main obj)) + (grace (ly:moment-grace obj))) + (cond ((zero? grace) (list main)) + ((negative? grace) (list main grace)) + (else ;;positive grace requires 4-arg form + (list (numerator main) + (denominator main) + (numerator grace) + (denominator grace))))))) + (;; note duration + (ly:duration? obj) + `(ly:make-duration ,(ly:duration-log obj) + ,@(if (= (ly:duration-scale obj) 1) + (if-nonzero (ly:duration-dot-count obj)) + (list (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) + ,@(if-nonzero (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))) @@ -218,15 +239,14 @@ which often can be read back in order to generate an equivalent expression." (use-modules (srfi srfi-39) (scm display-lily)) -(define*-public (display-lily-music expr parser #:optional (port (current-output-port)) - #:key force-duration) +(define*-public (display-lily-music expr #:optional (port (current-output-port)) + #: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))) + (*omit-duration* #f)) + (display (music->lily-string expr) port) + (newline port))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -236,76 +256,108 @@ 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))) + ;clear cached length, since it's no longer valid + (set! (ly:music-property music 'length) '()) 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 -properly." +(define-public (tremolo::get-music-list tremolo) + "Given a tremolo repeat, return a list of music to engrave for it. +This will be a stretched copy of its body, plus a TremoloEvent or +TremoloSpanEvent. + +This is called only by Chord_tremolo_iterator." (define (first-note-duration music) - "Finds the duration of the first NoteEvent by searching depth-first -through MUSIC." + "Finds the duration of the first NoteEvent by searching +depth-first 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)))))))) - - (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))) - (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))) + (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* ((times (ly:music-property tremolo 'repeat-count)) + (body (ly:music-property tremolo 'element)) + (children (if (music-is-of-type? body 'sequential-music) + ;; \repeat tremolo n { ... } + (count duration-of-note ; do not count empty <> + (extract-named-music body + '(EventChord NoteEvent))) + ;; \repeat tremolo n c4 + 1)) + (tremolo-type (if (positive? children) + (let* ((note-duration (first-note-duration body)) + (duration-log (if (ly:duration? note-duration) + (ly:duration-log note-duration) + 1))) + (ash 1 duration-log)) + '())) + (stretched (ly:music-deep-copy body))) + (if (positive? children) + ;; # of dots is equal to the 1 in bitwise representation (minus 1)! + (let* ((dots (1- (logcount (* times children)))) + ;; The remaining missing multiplier to scale the notes by + ;; times * children + (mult (/ (* times children (ash 1 dots)) (1- (ash 2 dots)))) + (shift (- (ly:intlog2 (floor mult))))) + (if (not (and (integer? mult) (= (logcount mult) 1))) + (ly:music-warning + body + (ly:format (_ "invalid tremolo repeat count: ~a") times))) + ;; Make each note take the full duration + (ly:music-compress stretched (ly:make-moment 1 children)) + ;; Adjust the displayed note durations + (shift-duration-log stretched shift dots))) + ;; Return the stretched body plus a tremolo event + (if (= children 1) + (list (make-music 'TremoloEvent + 'repeat-count times + 'tremolo-type tremolo-type + 'origin (ly:music-property tremolo 'origin)) + stretched) + (list (make-music 'TremoloSpanEvent + 'span-direction START + 'repeat-count times + 'tremolo-type tremolo-type + 'origin (ly:music-property tremolo 'origin)) + stretched + (make-music 'TremoloSpanEvent + 'span-direction STOP + 'origin (ly:music-property tremolo 'origin)))))) + +(define-public (make-repeat name times main alts) + "Create a repeat music expression, with all properties initialized +properly." + (let ((type (or (assoc-get name '(("volta" . VoltaRepeatedMusic) + ("unfold" . UnfoldedRepeatedMusic) + ("percent" . PercentRepeatedMusic) + ("tremolo" . TremoloRepeatedMusic))) + (begin (ly:warning (_ "unknown repeat type `~S': must be volta, unfold, percent, or tremolo") name) + 'VoltaRepeatedMusic))) + (talts (if (< times (length alts)) + (begin + (ly:warning (_ "More alternatives than repeats. Junking excess alternatives")) + (take alts times)) + alts))) + (make-music type + 'element main + 'repeat-count (max times 1) + 'elements talts))) (define (calc-repeat-slash-count music) "Given the child-list @var{music} in @code{PercentRepeatMusic}, @@ -313,13 +365,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 +380,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) @@ -338,54 +390,50 @@ beats to be distinguished." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; repeats. -(define-public (unfold-repeats music) - "Replace all repeats with unfolded repeats." - - (let ((es (ly:music-property music 'elements)) - (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)))))) - - (if (pair? es) - (set! (ly:music-property music 'elements) - (map unfold-repeats es))) - (if (ly:music? e) - (set! (ly:music-property music 'element) - (unfold-repeats e))) - music)) +(define-public (unfold-repeats types music) + "Replace repeats of the types given by @var{types} with unfolded repeats. +If @var{types} is an empty list, @code{repeated-music} is taken, unfolding all." + (let* ((types-list + (if (or (null? types) (not (list? types))) + (list types) + types)) + (repeat-types-alist + '((volta . volta-repeated-music) + (percent . percent-repeated-music) + (tremolo . tremolo-repeated-music) + (() . repeated-music))) + (repeat-types-hash (alist->hash-table repeat-types-alist))) + (for-each + (lambda (type) + (let ((repeat-type (hashq-ref repeat-types-hash type))) + (if repeat-type + (let ((es (ly:music-property music 'elements)) + (e (ly:music-property music 'element))) + (if (music-is-of-type? music repeat-type) + (set! music (make-music 'UnfoldedRepeatedMusic music))) + (if (pair? es) + (set! (ly:music-property music 'elements) + (map (lambda (x) (unfold-repeats types x)) es))) + (if (ly:music? e) + (set! (ly:music-property music 'element) + (unfold-repeats types e)))) + (ly:warning "unknown repeat-type ~a, ignoring." type)))) + types-list) + music)) + +(define-public (unfold-repeats-fully music) + "Unfolds repeats and expands the resulting @code{unfolded-repeated-music}." + (map-some-music + (lambda (m) + (and (music-is-of-type? m 'unfolded-repeated-music) + (make-sequential-music + (ly:music-deep-copy (make-unfolded-set m))))) + (unfold-repeats '() music))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; property setting music objs. -(define-safe-public (check-grob-path path #:optional parser location +(define-safe-public (check-grob-path path #:optional location #:key (start 0) default @@ -454,35 +502,83 @@ respectively." (<= min (length res)))) res (begin - (if parser - (ly:parser-error parser - (format #f (_ "bad grob property path ~a") - path) - location)) + (ly:parser-error + (format #f (_ "bad grob property path ~a") + path) + location) #f))))) +(define-safe-public (check-context-path path #:optional location) + "Check a context property path specification @var{path}, a symbol +list (or a single symbol), for validity and possibly complete it. +Returns the completed specification, or @code{#f} when rising an +error (using optionally @code{location})." + (let* ((path (if (symbol? path) (list path) path))) + ;; A Guile 1.x bug specific to optargs precludes moving the + ;; defines out of the let + (define (property? s) + (object-property s 'translation-type?)) + (define (unspecial? s) + (not (property? s))) + (define (check c p) (c p)) + (or (case (length path) + ((1) (and (property? (car path)) (cons 'Bottom path))) + ((2) (and (unspecial? (car path)) (property? (cadr path)) path)) + (else #f)) + (begin + (ly:parser-error + (format #f (_ "bad context property ~a") + path) + location) + #f)))) + +(define-safe-public (check-music-path path #:optional location #:key default) + "Check a music property path specification @var{path}, a symbol +list (or a single symbol), for validity and possibly complete it. +Returns the completed specification, or @code{#f} when rising an +error (using optionally @code{location})." + (let* ((path (if (symbol? path) (list path) path))) + ;; A Guile 1.x bug specific to optargs precludes moving the + ;; defines out of the let + (define (property? s) + (object-property s 'music-type?)) + (define (unspecial? s) + (not (property? s))) + (or (case (length path) + ((1) (and (property? (car path)) (cons default path))) + ((2) (and (unspecial? (car path)) (property? (cadr path)) path)) + (else #f)) + (begin + (ly:parser-error + (format #f (_ "bad music property ~a") + path) + location) + #f)))) + (define-public (make-grob-property-set grob gprop val) - "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 a @code{Music} expression that overrides a @var{gprop} to +@var{val} in @var{grob}. Does a pop first, i.e. this is not a +@code{\\temporary \\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 a @code{Music} expression that overrides @var{gprop} to +@var{val} in @var{grob}. This is a @code{\\temporary \\override}, +making it possible to @code{\\revert} to any previous value afterwards." (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 @@ -491,6 +587,7 @@ in @var{grob}." Fingering LaissezVibrerTie LigatureBracket + MultiMeasureRest PhrasingSlur RepeatTie Rest @@ -502,163 +599,164 @@ in @var{grob}." TupletBracket TrillSpanner)) +(define general-grace-settings + `((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))) + +(define-public score-grace-settings + (append + `((Voice Stem direction ,UP) + (Voice Slur direction ,DOWN)) + general-grace-settings)) + +;; Getting a unique context id name + +(define-session unique-counter -1) +(define-safe-public (get-next-unique-voice-name) + (set! unique-counter (1+ unique-counter)) + (format #f "uniqueContext~s" unique-counter)) + + (define-safe-public (make-voice-props-set n) (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))) - - (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2)) - (make-grob-property-set 'MultiMeasureRest 'staff-position (if (odd? n) -4 4)))))) + (make-property-set 'graceSettings general-grace-settings) + (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2)))))) (define-safe-public (make-voice-props-override n) (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))) - - (make-grob-property-override 'NoteColumn 'horizontal-shift (quotient n 2)) - (make-grob-property-override 'MultiMeasureRest 'staff-position (if (odd? n) -4 4)))))) + (make-property-set 'graceSettings general-grace-settings) + (make-grob-property-override 'NoteColumn 'horizontal-shift (quotient n 2)))))) (define-safe-public (make-voice-props-revert) (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))))) -(define-safe-public (context-spec-music m context #:optional id) - "Add \\context CONTEXT = ID to M." +(define-safe-public (context-spec-music m context #:optional id mods) + "Add \\context @var{context} = @var{id} \\with @var{mods} to @var{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)) + (if mods + (set! (ly:music-property cm 'property-operations) + (if (ly:context-mod? mods) + (ly:get-context-mods mods) + mods))) cm)) -(define-public (descend-to-context m context) +(define-safe-public (descend-to-context m context #:optional id mods) "Like @code{context-spec-music}, but only descending." - (let ((cm (context-spec-music m context))) + (let ((cm (context-spec-music m context id mods))) (ly:music-set-property! cm 'descend-only #t) cm)) (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)) +(define-safe-public (make-articulation name . properties) + (apply make-music 'ArticulationEvent + 'articulation-type name + properties)) (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) @@ -669,17 +767,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?" @@ -688,7 +786,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 @@ -698,49 +796,48 @@ duration is replaced with the specified @var{duration}." ;; articulations on individual events since they can't actually get ;; into a repeat chord given its input syntax. - (define (keep-element? m) - (any (lambda (t) (music-is-of-type? m t)) - 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)) - l) + (define keep-element? (music-type-predicate event-types)) (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 + (ly:music-deep-copy (filter keep-element? + (ly:music-property original-chord + 'elements)) + repeat-chord))) + (for-each + (lambda (m) + (let ((arts (ly:music-property m 'articulations))) + (if (pair? arts) + (set! (ly:music-property m 'articulations) + (ly:set-origin! (filter! keep-element? arts) + repeat-chord))) + (if (ly:duration? (ly:music-property m 'duration)) + (set! (ly:music-property m 'duration) duration)) + (if (ly:music-property m 'cautionary #f) + (set! (ly:music-property m 'cautionary) #f)) + (if (ly:music-property m 'force-accidental #f) + (set! (ly:music-property m 'force-accidental) #f)))) + 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! + (ly:music-deep-copy arts repeat-chord) + (ly:music-property repeat-chord 'articulations))))) + repeat-chord) (define-public (expand-repeat-chords! event-types music) @@ -749,66 +846,167 @@ 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)) + (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) +;;; This does _not_ copy any articulations. Rationale: one main +;;; incentive for pitch-repeating durations is after ties, such that +;;; 4~2~8. can stand in for a 15/16 note in \partial 4 position. In +;;; this use case, any repeated articulations will be a nuisance. +;;; +;;; String assignments in TabStaff might seem like a worthwhile +;;; exception, but they would be better tackled by the respective +;;; engravers themselves (see issue 3662). +;;; +;;; Repeating chords as well seems problematic for things like +;;; \score { +;;; << +;;; \new Staff { c4 c c } +;;; \new RhythmicStaff { 4 4 4 4 } +;;; >> +;;; } +;;; +;;; However, because of MIDI it is not advisable to use RhythmicStaff +;;; without any initial pitch/drum-type. For music functions taking +;;; pure rhythms as an argument, the running of expand-repeat-notes! +;;; at scorification time is irrelevant: at that point of time, the +;;; music function has already run. + +(define-public (expand-repeat-notes! music) + "Walks through @var{music} and gives pitchless notes (not having a +pitch in code{pitch} or a drum type in @code{drum-type}) the pitch(es) +from the predecessor note/chord if available." + (let ((last-pitch #f)) + (map-some-music + (lambda (m) + (define (set-and-ret last) + (set! last-pitch last) + m) + (cond + ((music-is-of-type? m 'event-chord) + (if (any (lambda (m) (music-is-of-type? m 'rhythmic-event)) + (ly:music-property m 'elements)) + (set! last-pitch m)) + m) + ((music-is-of-type? m 'note-event) + (cond + ((or (ly:music-property m 'pitch #f) + (ly:music-property m 'drum-type #f)) + => set-and-ret) + ;; ok, naked rhythm. Go through the various cases of + ;; last-pitch + ;; nothing available: just keep as-is + ((not last-pitch) m) + ((ly:pitch? last-pitch) + (set! (ly:music-property m 'pitch) last-pitch) + m) + ((symbol? last-pitch) + (set! (ly:music-property m 'drum-type) last-pitch) + m) + ;; Ok, this is the big bad one: the reference is a chord. + ;; For now, we use the repeat chord logic. That's not + ;; really efficient as cleaning out all articulations is + ;; quite simpler than what copy-repeat-chord does. + (else + (copy-repeat-chord last-pitch + (make-music 'EventChord + 'elements + (ly:music-property m 'articulations) + 'origin + (ly:music-property m 'origin)) + (ly:music-property m 'duration) + '(rhythmic-event))))) + (else #f))) + music))) + ;;; splitting chords into voices. -(define (voicify-list lst number) +(define (voicify-list locs lst id) "Make a list of Musics. -voicify-list :: [ [Music ] ] -> number -> [Music] +voicify-list :: [ [Music ] ] -> id -> [Music] LST is a list music-lists. -NUMBER is 0-base, i.e., Voice=1 (upstems) has number 0. +id is 1-based, i.e., Voice=1 (upstems) has number 1. + +id may be a symbol or string giving a specific voice id: in this +case, no \voiceXXX style is selected, merely the context given. + +locs is a list of music expressions suitable for giving +error locations (enclosing expression for the first element, +preceding \\\\ separator for the others) " - (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))))) - -(define (voicify-chord ch) + (define (voicify-sublist loc sublist id) + (cond ((string? id) + (context-spec-music + (make-simultaneous-music sublist) + 'Bottom id)) + ((symbol? id) + (voicify-sublist loc sublist (symbol->string id))) + ((and (integer? id) (exact? id) (positive? id)) + (context-spec-music + (make-sequential-music + (list (make-voice-props-set (1- id)) + (make-simultaneous-music sublist))) + 'Bottom (number->string id))) + (else + (ly:music-warning loc (_ "Bad voice id: ~a") id) + (context-spec-music (make-simultaneous-music sublist) 'Bottom)))) + + (cond ((null? lst) '()) + ((number? id) + (cons (voicify-sublist (car locs) (car lst) id) + (voicify-list (cdr locs) (cdr lst) (1+ id)))) + ((pair? id) + (cons (voicify-sublist (car locs) (car lst) (car id)) + (voicify-list (cdr locs) (cdr lst) (cdr id)))) + ((null? id) + (ly:music-warning (car locs) (_ "\\voices needs more ids")) + (voicify-list locs lst 1)))) + +(define (voicify-chord ch id) "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 (cons ch (filter music-separator? es)) + (split-list-by-separator es music-separator?) + id)) ch)) -(define-public (voicify-music m) - "Recursively split chords that are separated with @code{\\\\}." - (if (not (ly:music? m)) - (ly:error (_ "music expected: ~S") m)) - (let ((es (ly:music-property m 'elements)) - (e (ly:music-property m 'element))) - - (if (pair? es) - (set! (ly:music-property m 'elements) (map voicify-music es))) - (if (ly:music? e) - (set! (ly:music-property m 'element) (voicify-music e))) - (if (and (equal? (ly:music-property m 'name) 'SimultaneousMusic) - (reduce (lambda (x y ) (or x y)) #f (map music-separator? es))) - (set! m (context-spec-music (voicify-chord m) 'Staff))) - m)) +(define*-public (voicify-music m #:optional (id 1)) + "Recursively split chords that are separated with @code{\\\\}. +Optional @var{id} can be a list of context ids to use. If numeric, +they also indicate a voice type override. If @var{id} is just a single +number, that's where numbering starts." + (let loop ((m m)) + (if (not (ly:music? m)) + (ly:error (_ "music expected: ~S") m)) + (let ((es (ly:music-property m 'elements)) + (e (ly:music-property m 'element))) + + (if (pair? es) + (set! (ly:music-property m 'elements) (map loop es))) + (if (ly:music? e) + (set! (ly:music-property m 'element) (loop e))) + (if (and (equal? (ly:music-property m 'name) 'SimultaneousMusic) + (any music-separator? es)) + (context-spec-music (voicify-chord m id) 'Staff) + m)))) (define-public (empty-music) (make-music 'Music)) @@ -818,17 +1016,19 @@ NUMBER is 0-base, i.e., Voice=1 (upstems) has number 0. (lambda (elt) (grob::has-interface elt symbol))) -(define-public ((outputproperty-compatibility func sym val) grob g-context ao-context) +(define ((outputproperty-compatibility func sym val) grob g-context ao-context) (if (func grob) (set! (ly:grob-property grob sym) val))) +(export outputproperty-compatibility) -(define-public ((set-output-property grob-name symbol val) grob grob-c context) +(define ((set-output-property grob-name symbol val) grob grob-c context) "Usage example: @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)))) +(export set-output-property) (define-public (skip->rest mus) @@ -836,39 +1036,62 @@ 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)) - - -(define-public (music-has-type music type) - (memq type (ly:music-property music 'types))) - -(define-public (music-clone music) - (define (alist->args alist acc) - (if (null? alist) - acc - (alist->args (cdr alist) - (cons (caar alist) (cons (cdar alist) acc))))) - - (apply - make-music - (ly:music-property music 'name) - (alist->args (ly:music-mutable-properties music) '()))) + (make-music 'RestEvent 'duration (ly:music-property mus 'duration)) + mus)) + + +(define-public (music-clone music . music-properties) + "Clone @var{music} and set properties according to +@var{music-properties}, a list of alternating property symbols and +values: +@example\n(music-clone start-span 'span-direction STOP) +@end example +Only properties that are not overriden by @var{music-properties} are +actually fully cloned." + (let ((old-props (list-copy (ly:music-mutable-properties music))) + (new-props '()) + (m (ly:make-music (ly:prob-immutable-properties music)))) + (define (set-props mus-props) + (if (and (not (null? mus-props)) + (not (null? (cdr mus-props)))) + (begin + (set! old-props (assq-remove! old-props (car mus-props))) + (set! new-props + (assq-set! new-props + (car mus-props) (cadr mus-props))) + (set-props (cddr mus-props))))) + (set-props music-properties) + (for-each + (lambda (pair) + (set! (ly:music-property m (car pair)) + (ly:music-deep-copy (cdr pair)))) + old-props) + (for-each + (lambda (pair) + (set! (ly:music-property m (car pair)) (cdr pair))) + new-props) + m)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; warn for bare chords at start. -(define-public (ly:music-message music msg) +(define-public (ly:music-message music msg . rest) (let ((ip (ly:music-property music 'origin))) (if (ly:input-location? ip) - (ly:input-message ip msg) - (ly:message msg)))) + (apply ly:input-message ip msg rest) + (apply ly:message msg rest)))) -(define-public (ly:music-warning music msg) +(define-public (ly:music-warning music msg . rest) (let ((ip (ly:music-property music 'origin))) (if (ly:input-location? ip) - (ly:input-warning ip msg) - (ly:warning msg)))) + (apply ly:input-warning ip msg rest) + (apply ly:warning msg rest)))) + +(define-public (ly:event-warning event msg . rest) + (let ((ip (ly:event-property event 'origin))) + (if (ly:input-location? ip) + (apply ly:input-warning ip msg rest) + (apply ly:warning msg rest)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -878,7 +1101,7 @@ NUMBER is 0-base, i.e., Voice=1 (upstems) has number 0. (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)) @@ -899,12 +1122,12 @@ NUMBER is 0-base, i.e., Voice=1 (upstems) has number 0. (define-public (add-grace-property context-name grob sym val) "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))))) + (let* ((where (or (ly:context-find context context-name) context)) + (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)) + (make-apply-context set-prop)) (define-public (remove-grace-property context-name grob sym) "Remove all @var{sym} for @var{grob} in @var{context-name}." @@ -913,35 +1136,33 @@ NUMBER is 0-base, i.e., Voice=1 (upstems) has number 0. (eq? (cadr property) grob) (eq? (caddr property) sym))) (define (delete-prop context) - (let* ((where (ly:context-property-where-defined context 'graceSettings)) - (current (ly:context-property where 'graceSettings)) + (let* ((where (or (ly:context-find context context-name) context)) + (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)) - + (make-apply-context delete-prop)) (defmacro-public def-grace-function (start stop . docstring) "Helper macro for defining grace music" - `(define-music-function (parser location music) (ly:music?) + `(define-music-function (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)))))) + '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'. Syntax: - (define-syntax-function result-type? (parser location arg1 arg2 ...) (arg1-type arg2-type ...) + (define-syntax-function result-type? (arg1 arg2 ...) (arg1-type arg2-type ...) ...function body...) argX-type can take one of the forms @code{predicate?} for mandatory @@ -952,37 +1173,58 @@ value (evaluated at definition time). An optional parameter can be omitted in a call only when it can't get confused with a following parameter of different type. -Predicates with syntactical significance are @code{ly:pitch?}, -@code{ly:duration?}, @code{ly:music?}, @code{markup?}. Other -predicates require the parameter to be entered as Scheme expression. - @code{result-type?} can specify a default in the same manner as 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 (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))) - `(ly:make-music-function (list ,@signature) - (lambda ,args - ,@body)))) + (define (has-parser/location? arg where) + (let loop ((arg arg)) + (if (list? arg) + (any loop arg) + (memq arg where)))) + (define (currying-lambda args doc-string? body) + (if (and (pair? args) + (pair? (car args))) + (currying-lambda (car args) doc-string? + `((lambda ,(cdr args) ,@body))) + (let* ((compatibility? (if (list? args) + (= (length args) (+ 2 (length signature))) + (and (pair? args) (pair? (cdr args)) + (eq? (car args) 'parser)))) + (realargs (if compatibility? (cddr args) args))) + `(lambda ,realargs + ,(format #f "~a\n~a" realargs (or doc-string? "")) + ,@(if (and compatibility? + (has-parser/location? body (take args 2))) + `((let ((,(car args) (*parser*)) (,(cadr args) (*location*))) + ,@body)) + body))))) + + (let ((docstring + (and (pair? body) (pair? (cdr body)) + (if (string? (car body)) + (car body) + (and (pair? (car body)) + (eq? '_i (caar body)) + (pair? (cdar body)) + (string? (cadar body)) + (null? (cddar body)) + (cadar body)))))) + ;; When the music function definition contains an i10n doc string, + ;; (_i "doc string"), keep the literal string only + `(ly:make-music-function + (list ,@(map (lambda (pred) + (if (pair? pred) + `(cons ,(car pred) + ,(and (pair? (cdr pred)) (cadr pred))) + pred)) + (cons type signature))) + ,(currying-lambda args docstring (if docstring (cdr body) body))))) (defmacro-public define-music-function rest "Defining macro returning music functions. Syntax: - (define-music-function (parser location arg1 arg2 ...) (arg1-type? arg2-type? ...) + (define-music-function (arg1 arg2 ...) (arg1-type? arg2-type? ...) ...function body...) argX-type can take one of the forms @code{predicate?} for mandatory @@ -993,10 +1235,6 @@ value (evaluated at definition time). An optional parameter can be omitted in a call only when it can't get confused with a following parameter of different type. -Predicates with syntactical significance are @code{ly:pitch?}, -@code{ly:duration?}, @code{ly:music?}, @code{markup?}. Other -predicates require the parameter to be entered as Scheme expression. - Must return a music expression. The @code{origin} is automatically set to the @code{location} parameter." @@ -1006,7 +1244,7 @@ set to the @code{location} parameter." (defmacro-public define-scheme-function rest "Defining macro returning Scheme functions. Syntax: - (define-scheme-function (parser location arg1 arg2 ...) (arg1-type? arg2-type? ...) + (define-scheme-function (arg1 arg2 ...) (arg1-type? arg2-type? ...) ...function body...) argX-type can take one of the forms @code{predicate?} for mandatory @@ -1017,10 +1255,6 @@ value (evaluated at definition time). An optional parameter can be omitted in a call only when it can't get confused with a following parameter of different type. -Predicates with syntactical significance are @code{ly:pitch?}, -@code{ly:duration?}, @code{ly:music?}, @code{markup?}. Other -predicates require the parameter to be entered as Scheme expression. - Can return arbitrary expressions. If a music expression is returned, its @code{origin} is automatically set to the @code{location} parameter." @@ -1038,7 +1272,7 @@ the return value." (defmacro-public define-event-function rest "Defining macro returning event functions. Syntax: - (define-event-function (parser location arg1 arg2 ...) (arg1-type? arg2-type? ...) + (define-event-function (arg1 arg2 ...) (arg1-type? arg2-type? ...) ...function body...) argX-type can take one of the forms @code{predicate?} for mandatory @@ -1049,10 +1283,6 @@ value (evaluated at definition time). An optional parameter can be omitted in a call only when it can't get confused with a following parameter of different type. -Predicates with syntactical significance are @code{ly:pitch?}, -@code{ly:duration?}, @code{ly:music?}, @code{markup?}. Other -predicates require the parameter to be entered as Scheme expression. - Must return an event expression. The @code{origin} is automatically set to the @code{location} parameter." @@ -1065,58 +1295,59 @@ 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))) + (cue-type (ly:music-property quote-music 'quoted-context-type #f)) + (cue-id (ly:music-property quote-music 'quoted-context-id)) + (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)) + (and cue-type cue-voice + (context-spec-music + (make-voice-props-override cue-voice) + cue-type cue-id)) + quote-music + (and cue-type cue-voice + (context-spec-music + (make-voice-props-revert) + cue-type cue-id)) + (and clef (make-cue-clef-unset)))))) quote-music)) -(define-public ((quote-substitute quote-tab) music) +(define ((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)) +(export quote-substitute) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1133,8 +1364,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)) @@ -1145,29 +1376,29 @@ 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)))) - -(define (skip-as-needed music parser) + (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) "Replace MUSIC by << { \\set skipTypesetting = ##f LENGTHOF(\\showFirstLength) @@ -1180,12 +1411,12 @@ then revert skipTypesetting." the 'length property of the music is overridden to speed up compiling." (let* - ((show-last (ly:parser-lookup parser 'showLastLength)) - (show-first (ly:parser-lookup parser 'showFirstLength)) + ((show-last (ly:parser-lookup 'showLastLength)) + (show-first (ly:parser-lookup '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, @@ -1229,25 +1460,23 @@ then revert skipTypesetting." (else music)))) -(define-public toplevel-music-functions +(define-session-public toplevel-music-functions (list - (lambda (music parser) (expand-repeat-chords! - (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)) - (lambda (music parser) - - (music-map (quote-substitute (ly:parser-lookup parser 'musicQuotes)) music)) + (lambda (music) (expand-repeat-chords! + (cons 'rhythmic-event + (ly:parser-lookup '$chord-repeat-events)) + music)) + expand-repeat-notes! + voicify-music + (lambda (x) (music-map music-check-error x)) + (lambda (x) (music-map precompute-music-length x)) + (lambda (music) + (music-map (quote-substitute (ly:parser-lookup 'musicQuotes)) music)) ;; switch-on-debugging - (lambda (x parser) (music-map cue-substitute x)) + (lambda (x) (music-map cue-substitute x)) - (lambda (x parser) - (skip-as-needed x parser) - ))) + skip-as-needed)) ;;;;;;;;;; ;;; general purpose music functions @@ -1255,9 +1484,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))) ;;;;;;;;;;;;;;;;; @@ -1266,10 +1495,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)) @@ -1291,70 +1520,73 @@ 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) +(define (check-pitch-against-signature context pitch barnum laziness octaveness all-naturals) "Checks the need for an accidental and a @q{restore} accidental against -@code{localKeySignature}. The @var{laziness} is the number of measures +@code{localAlterations} and @code{keyAlterations}. +The @var{laziness} is the number of measures for which reminder accidentals are used (i.e., if @var{laziness} is zero, only cancel accidentals in the same measure; if @var{laziness} is three, 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." +specifies whether accidentals should be canceled in different octaves. +If @var{all-naturals} is ##t, notes that do not occur in @code{keyAlterations} +also get an accidental." (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)))) - - ;; loop through localKeySignature to search for a notename match from other octaves - (let loop ((l local-key-sig)) + ((equal? octaveness 'same-octave) #f) + (else + (ly:warning (_ "Unknown octaveness type: ~S ") octaveness) + (ly:warning (_ "Defaulting to 'any-octave.")) + #t))) + (key (ly:context-property context 'keyAlterations)) + (local (ly:context-property context 'localAlterations)) + (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)) + (from-key-sig (or (assoc-get notename local) + + ;; If no notename match is found from localAlterations, 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 + ;; localAlterations, try extracting from keyAlterations instead. + (assoc-get pitch-handle key)))) + + ;; loop through localAlterations to search for a notename match from other octaves + (let loop ((l local)) (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 @@ -1362,22 +1594,22 @@ 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 (or (and all-naturals (eq? #f previous-alteration)) (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))) -(define-public ((make-accidental-rule octaveness laziness) context pitch barnum measurepos) +(define ((make-accidental-rule octaveness laziness) context pitch barnum measurepos) "Create an accidental rule that makes its decision based on the octave of the note and a laziness value. @@ -1394,10 +1626,18 @@ is, to the end of current measure. A positive integer means that the accidental lasts over that many bar lines. @w{@code{-1}} is `forget immediately', that is, only look at key signature. @code{#t} is `forever'." - (check-pitch-against-signature context pitch barnum laziness octaveness)) + (check-pitch-against-signature context pitch barnum laziness octaveness #f)) +(export make-accidental-rule) + +(define ((make-accidental-dodecaphonic-rule octaveness laziness) context pitch barnum measurepos) + "Variation on function make-accidental-rule that creates an dodecaphonic +accidental rule." + + (check-pitch-against-signature context pitch barnum laziness octaveness #t)) +(export make-accidental-dodecaphonic-rule) (define (key-entry-notename entry) - "Return the pitch of an @var{entry} in @code{localKeySignature}. + "Return the pitch of an @var{entry} in @code{localAlterations}. The @samp{car} of the entry is either of the form @code{notename} or of the form @code{(octave . notename)}. The latter form is used for special key signatures or to indicate an explicit accidental. @@ -1411,294 +1651,340 @@ an accidental in music." (car entry))) (define (key-entry-octave entry) - "Return the octave of an entry in @code{localKeySignature} + "Return the octave of an entry in @code{localAlterations} or @code{#f} if the entry does not have an octave. See @code{key-entry-notename} for details." (and (pair? (car entry)) (caar entry))) (define (key-entry-bar-number entry) - "Return the bar number of an entry in @code{localKeySignature} + "Return the bar number of an entry in @code{localAlterations} or @code {#f} if the entry does not have a bar number. See @code{key-entry-notename} for details." (and (pair? (cdr entry)) (caddr entry))) (define (key-entry-measure-position entry) - "Return the measure position of an entry in @code{localKeySignature} + "Return the measure position of an entry in @code{localAlterations} or @code {#f} if the entry does not have a measure position. See @code{key-entry-notename} for details." (and (pair? (cdr entry)) (cdddr entry))) (define (key-entry-alteration entry) - "Return the alteration of an entry in localKeySignature. + "Return the alteration of an entry in localAlterations 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) - "Return the first entry in @var{keysig} that matches @var{pitch}. + "Return the first entry in @var{keysig} that matches @var{pitch} +by notename and octave. Alteration is not considered. @var{accept-global} states whether key signature entries should be included. @var{accept-local} states whether local accidentals should be included. 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 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))) + (let* ((keysig (ly:context-property context 'localAlterations)) + (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 (dodecaphonic-no-repeat-rule context pitch barnum measurepos) + "An accidental rule that typesets an accidental before every +note (just as in the dodecaphonic accidental style) @emph{except} if +the note is immediately preceded by a note with the same pitch. This +is a common accidental style in contemporary notation." + (let* ((keysig (ly:context-property context 'localAlterations)) + (entry (find-pitch-entry keysig pitch #f #t))) + (if (not entry) + (cons #f #t) + (let ((entrymp (key-entry-measure-position entry)) + (entrybn (key-entry-bar-number entry)) + (entryalt (key-entry-alteration entry)) + (alt (ly:pitch-alteration pitch))) + (cons #t + (not (and (equal? entrybn barnum) + (or (equal? measurepos entrymp) + (ly:moment= (length siblings) 2) + (helper siblings arg) + (car arg)))) +(export value-for-spanner-piece) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The following are used by the \offset function + +(define (find-value-to-offset prop self alist) + "Return the first value of the property @var{prop} in the property +alist @var{alist} -- after having found @var{self}. If @var{self} is +not found, return the first value of @var{prop}." + (let ((segment (member (cons prop self) alist))) + (if (not segment) + (assoc-get prop alist) + (assoc-get prop (cdr segment))))) + +(define (offset-multiple-types arg offsets) + "Displace @var{arg} by @var{offsets} if @var{arg} is a number, a +number pair, or a list of number pairs. If @var{offsets} is an empty +list or if there is a type-mismatch, @var{arg} will be returned." + (cond + ((and (number? arg) (number? offsets)) + (+ arg offsets)) + ((and (number-pair? arg) + (or (number? offsets) + (number-pair? offsets))) + (coord-translate arg offsets)) + ((and (number-pair-list? arg) (number-pair-list? offsets)) + (map coord-translate arg offsets)) + (else arg))) + +(define-public (grob-transformer property func) + "Create an override value good for applying @var{func} to either +pure or unpure values. @var{func} is called with the respective grob +as first argument and the default value (after resolving all callbacks) +as the second." + (define (worker self caller grob . rest) + (let* ((immutable (ly:grob-basic-properties grob)) + ;; We need to search the basic-properties alist for our + ;; property to obtain values to offset. Our search is + ;; complicated by the fact that calling the music function + ;; `offset' as an override conses a pair to the head of the + ;; alist. This pair must be discounted. The closure it + ;; contains is named `self' so it can be easily recognized. + ;; If `offset' is called as a tweak, the basic-property + ;; alist is unaffected. + (target (find-value-to-offset property self immutable)) + ;; if target is a procedure, we need to apply it to our + ;; grob to calculate values to offset. + (vals (apply caller target grob rest))) + (func grob vals))) + ;; return the container named `self'. The container self-reference + ;; seems like chasing its own tail but gets dissolved by + ;; define/lambda separating binding and referencing of "self". + (define self (ly:make-unpure-pure-container + (lambda (grob) + (worker self ly:unpure-call grob)) + (lambda (grob . rest) + (apply worker self ly:pure-call grob rest)))) + self) + +(define-public (offsetter property offsets) + "Apply @var{offsets} to the default values of @var{property} of @var{grob}. +Offsets are restricted to immutable properties and values of type @code{number}, +@code{number-pair}, or @code{number-pair-list}." + (define (offset-fun grob vals) + (let ((can-type-be-offset? + (or (number? vals) + (number-pair? vals) + (number-pair-list? vals)))) + (if can-type-be-offset? + ;; '(+inf.0 . -inf.0) would offset to itself. This will be + ;; confusing to a user unaware of the default value of the + ;; property, so issue a warning. + (if (equal? empty-interval vals) + (ly:warning "default '~a of ~a is ~a and can't be offset" + property grob vals) + (let* ((orig (ly:grob-original grob)) + (siblings + (if (ly:spanner? grob) + (ly:spanner-broken-into orig) + '())) + (total-found (length siblings)) + ;; Since there is some flexibility in input + ;; syntax, structure of `offsets' is normalized. + (offsets + (if (or (not (pair? offsets)) + (number-pair? offsets) + (and (number-pair-list? offsets) + (number-pair-list? vals))) + (list offsets) + offsets))) + + (define (helper sibs offs) + ;; apply offsets to the siblings of broken spanners + (if (pair? offs) + (if (eq? (car sibs) grob) + (offset-multiple-types vals (car offs)) + (helper (cdr sibs) (cdr offs))) + vals)) + + (if (>= total-found 2) + (helper siblings offsets) + (offset-multiple-types vals (car offsets))))) + + (begin + (ly:warning "the property '~a of ~a cannot be offset" property grob) + vals)))) + (grob-transformer property offset-fun)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; \magnifyMusic and \magnifyStaff + +;; defined as a function instead of a list because the +;; all-grob-descriptions alist is not available yet +(define-public (find-named-props prop-name grob-descriptions) + "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. When +@var{grob-descriptions} is equal to the @code{all-grob-descriptions} +alist (defined in @file{scm/define-grobs.scm}), this will find all grobs +that can have a value for the @var{prop-name} property, and return them +as a list in the following format: +@example +'((grob prop-name) + (grob prop-name) + ...) +@end example" + (define (find-grobs-with-interface interface grob-descriptions) + (define (has-this-interface? grob-desc) + (let* ((meta (ly:assoc-get 'meta (cdr grob-desc))) + (interfaces (ly:assoc-get 'interfaces meta '()))) + (memq interface interfaces))) + (let* ((grob-descriptions-with-this-interface + (filter has-this-interface? grob-descriptions)) + (grob-names-with-this-interface + (map car grob-descriptions-with-this-interface))) + grob-names-with-this-interface)) + (let* ((interface + (case prop-name + ((baseline-skip word-space) 'text-interface) + ((space-alist) 'break-aligned-interface) + (else (ly:programming-error + "find-named-props: no interface associated with ~s" + prop-name)))) + (grobs-with-this-prop + (find-grobs-with-interface interface grob-descriptions))) + (map (lambda (x) (list x prop-name)) + grobs-with-this-prop))) + + +(define (magnifyStaff-is-set? context mag) + (let* ((Staff (ly:context-find context 'Staff)) + (old-mag (ly:context-property Staff 'magnifyStaffValue))) + (not (null? old-mag)))) + +(define (staff-magnification-is-changing? context mag) + (let* ((Staff (ly:context-find context 'Staff)) + (old-mag (ly:context-property Staff 'magnifyStaffValue 1))) + (not (= old-mag mag)))) + +(define-public (scale-fontSize func-name mag) + "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. Look up the +current @code{fontSize} in the appropriate context and scale it by the +magnification factor @var{mag}. @var{func-name} is either +@code{'magnifyMusic} or @code{'magnifyStaff}." + (make-apply-context + (lambda (context) + (if (or (eq? func-name 'magnifyMusic) + ;; for \magnifyStaff, only scale the fontSize + ;; if staff magnification is changing + ;; and does not equal 1 + (and (staff-magnification-is-changing? context mag) + (not (= mag 1)))) + (let* ((where (case func-name + ((magnifyMusic) context) + ((magnifyStaff) (ly:context-find context 'Staff)))) + (fontSize (ly:context-property where 'fontSize 0)) + (new-fontSize (+ fontSize (magnification->font-size mag)))) + (ly:context-set-property! where 'fontSize new-fontSize)))))) + +(define-public (revert-fontSize func-name mag) + "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. Calculate +the previous @code{fontSize} value (before scaling) by factoring out the +magnification factor @var{mag} (if @var{func-name} is +@code{'magnifyMusic}), or by factoring out the context property +@code{magnifyStaffValue} (if @var{func-name} is @code{'magnifyStaff}). +Revert the @code{fontSize} in the appropriate context accordingly. + +With @code{\\magnifyMusic}, the scaling is reverted after the music +block it operates on. @code{\\magnifyStaff} does not operate on a music +block, so the scaling from a previous call (if there is one) is reverted +before the new scaling takes effect." + (make-apply-context + (lambda (context) + (if (or (eq? func-name 'magnifyMusic) + ;; for \magnifyStaff... + (and + ;; don't revert the user's fontSize choice + ;; the first time \magnifyStaff is called + (magnifyStaff-is-set? context mag) + ;; only revert the previous fontSize + ;; if staff magnification is changing + (staff-magnification-is-changing? context mag))) + (let* ((where + (case func-name + ((magnifyMusic) context) + ((magnifyStaff) (ly:context-find context 'Staff)))) + (old-mag + (case func-name + ((magnifyMusic) mag) + ((magnifyStaff) + (ly:context-property where 'magnifyStaffValue 1)))) + (fontSize (ly:context-property where 'fontSize 0)) + (old-fontSize (- fontSize (magnification->font-size old-mag)))) + (ly:context-set-property! where 'fontSize old-fontSize)))))) + +(define-public (scale-props func-name mag allowed-to-shrink? props) + "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. For each +prop in @var{props}, find the current value of the requested prop, scale +it by the magnification factor @var{mag}, and do the equivalent of a +@code{\\temporary@tie{}\\override} with the new value in the appropriate +context. If @var{allowed-to-shrink?} is @code{#f}, don't let the new +value be less than the current value. @var{func-name} is either +@code{'magnifyMusic} or @code{'magnifyStaff}. The @var{props} list is +formatted like: +@example +'((Stem thickness) + (Slur line-thickness) + ...) +@end example" + (make-apply-context + (lambda (context) + (define (scale-prop grob-prop-list) + (let* ((grob (car grob-prop-list)) + (prop (cadr grob-prop-list)) + (where (if (eq? grob 'SpacingSpanner) + (ly:context-find context 'Score) + (case func-name + ((magnifyMusic) context) + ((magnifyStaff) (ly:context-find context 'Staff))))) + (grob-def (ly:context-grob-definition where grob))) + (if (eq? prop 'space-alist) + (let* ((space-alist (ly:assoc-get prop grob-def)) + (scale-spacing-tuple (lambda (x) + (cons (car x) + (cons (cadr x) + (* mag (cddr x)))))) + (scaled-tuples (if space-alist + (map scale-spacing-tuple space-alist) + '())) + (new-alist (append scaled-tuples space-alist))) + (ly:context-pushpop-property where grob prop new-alist)) + (let* ((val (ly:assoc-get prop grob-def (case prop + ((baseline-skip) 3) + ((word-space) 0.6) + (else 1)))) + (proc (lambda (x) + (if allowed-to-shrink? + (* x mag) + (* x (max 1 mag))))) + (new-val (if (number-pair? val) + (cons (proc (car val)) + (proc (cdr val))) + (proc val)))) + (ly:context-pushpop-property where grob prop new-val))))) + (if (or (eq? func-name 'magnifyMusic) + ;; for \magnifyStaff, only scale the properties + ;; if staff magnification is changing + ;; and does not equal 1 + (and (staff-magnification-is-changing? context mag) + (not (= mag 1)))) + (for-each scale-prop props))))) + +(define-public (revert-props func-name mag props) + "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. Revert each +prop in @var{props} in the appropriate context. @var{func-name} is +either @code{'magnifyMusic} or @code{'magnifyStaff}. The @var{props} +list is formatted like: +@example +'((Stem thickness) + (Slur line-thickness) + ...) +@end example" + (make-apply-context + (lambda (context) + (define (revert-prop grob-prop-list) + (let* ((grob (car grob-prop-list)) + (prop (cadr grob-prop-list)) + (where (if (eq? grob 'SpacingSpanner) + (ly:context-find context 'Score) + (case func-name + ((magnifyMusic) context) + ((magnifyStaff) (ly:context-find context 'Staff)))))) + (ly:context-pushpop-property where grob prop))) + (if (or (eq? func-name 'magnifyMusic) + ;; for \magnifyStaff... + (and + ;; don't revert the user's property overrides + ;; the first time \magnifyStaff is called + (magnifyStaff-is-set? context mag) + ;; revert the overrides from the previous \magnifyStaff, + ;; but only if staff magnification is changing + (staff-magnification-is-changing? context mag))) + (for-each revert-prop props))))) + +;; \magnifyMusic only +(define-public (scale-beam-thickness mag) + "Used by @code{\\magnifyMusic}. Scaling @code{Beam.beam-thickness} +exactly to the @var{mag} value will not work. This uses two reference +values for @code{beam-thickness} to determine an acceptable value when +scaling, then does the equivalent of a +@code{\\temporary@tie{}\\override} with the new value." + (make-apply-context + (lambda (context) + (let* ((grob-def (ly:context-grob-definition context 'Beam)) + (val (ly:assoc-get 'beam-thickness grob-def 0.48)) + (ratio-to-default (/ val 0.48)) + ;; gives beam-thickness=0.48 when mag=1 (like default), + ;; gives beam-thickness=0.35 when mag=0.63 (like CueVoice) + (scaled-default (+ 119/925 (* mag 13/37))) + (new-val (* scaled-default ratio-to-default))) + (ly:context-pushpop-property context 'Beam 'beam-thickness new-val))))) + +;; tag management +;; + +(define tag-groups (make-hash-table)) +(call-after-session (lambda () (hash-clear! tag-groups))) + +(define-public (define-tag-group tags) + "Define a tag-group consisting of the given @var{tags}, a@tie{}list +of symbols. Returns @code{#f} if successful, and an error message if +there is a conflicting tag group definition." + (cond ((not (symbol-list? tags)) (format #f (_ "not a symbol list: ~a") tags)) + ((any (lambda (tag) (hashq-ref tag-groups tag)) tags) + => (lambda (group) (and (not (lset= eq? group tags)) + (format #f (_ "conflicting tag group ~a") group)))) + (else + (for-each + (lambda (elt) (hashq-set! tag-groups elt tags)) + tags) + #f))) - (if (>= (length siblings) 2) - (helper siblings arg) - (car arg)))) +(define-public (tag-group-get tag) + "Return the tag group (as a list of symbols) that the given +@var{tag} symbol belongs to, @code{#f} if none." + (hashq-ref tag-groups tag)) + +(define-public (tags-remove-predicate tags) + "Returns a predicate that returns @code{#f} for any music that is to +be removed by @{\\removeWithTag} on the given symbol or list of +symbols @var{tags}." + (if (symbol? tags) + (lambda (m) + (not (memq tags (ly:music-property m 'tags)))) + (lambda (m) + (not (any (lambda (t) (memq t tags)) + (ly:music-property m 'tags)))))) + +(define-public (tags-keep-predicate tags) + "Returns a predicate that returns @code{#f} for any music that is to +be removed by @{\\keepWithTag} on the given symbol or list of symbols +@var{tags}." + (if (symbol? tags) + (let ((group (tag-group-get tags))) + (lambda (m) + (let ((music-tags (ly:music-property m 'tags))) + (or + (null? music-tags) ; redundant but very frequent + ;; We know of only one tag to keep. Either we find it in + ;; the music tags, or all music tags must be from a + ;; different group + (memq tags music-tags) + (not (any (lambda (t) (eq? (tag-group-get t) group)) music-tags)))))) + (let ((groups (delete-duplicates (map tag-group-get tags) eq?))) + (lambda (m) + (let ((music-tags (ly:music-property m 'tags))) + (or + (null? music-tags) ; redundant but very frequent + (any (lambda (t) (memq t tags)) music-tags) + ;; if no tag matches, no tag group should match either + (not (any (lambda (t) (memq (tag-group-get t) groups)) music-tags))))))))