X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=4a97c1c664f635417366382c51e42891ab209228;hb=48678617b169957433c562612151f2a71be50b59;hp=8866c0e8877d75c374f42ee56cd85c8114a7c361;hpb=17f55d6aee8ef8a261ebd275e224444d4c4719ec;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 8866c0e887..4a97c1c664 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--2014 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,7 +29,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 +38,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 +62,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 +77,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 +109,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 +135,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 +158,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))) @@ -219,14 +230,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,76 +247,107 @@ 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 { ... } + (length (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 +355,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 +370,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) @@ -340,48 +382,38 @@ beats to be distinguished." (define-public (unfold-repeats music) "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)))))) - + (set! music (make-music 'UnfoldedRepeatedMusic music))) (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)) +(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 + (let ((n (ly:music-property m 'repeat-count)) + (alts (ly:music-property m 'elements)) + (body (ly:music-property m 'element))) + (cond ((<= n 0) '()) + ((null? alts) (make-list n body)) + (else + (concatenate + (zip (make-list n body) + (append! (make-list (max 0 (- n (length alts))) + (car alts)) + alts)))))))))) + (unfold-repeats music))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; property setting music objs. @@ -465,24 +497,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 @@ -491,6 +523,7 @@ in @var{grob}." Fingering LaissezVibrerTie LigatureBracket + MultiMeasureRest PhrasingSlur RepeatTie Rest @@ -502,77 +535,64 @@ 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)) + (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." (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) @@ -583,82 +603,83 @@ 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)) +(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 +690,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 +709,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 @@ -700,47 +721,48 @@ 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))))) + repeat-chord) (define-public (expand-repeat-chords! event-types music) @@ -749,26 +771,92 @@ 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) + (set-and-ret 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) "Make a list of Musics. @@ -781,17 +869,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) @@ -799,15 +887,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) - (reduce (lambda (x y ) (or x y)) #f (map 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) @@ -818,17 +906,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,8 +926,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) @@ -878,17 +968,23 @@ actually fully cloned." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -898,7 +994,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)) @@ -919,12 +1015,12 @@ actually fully cloned." (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}." @@ -933,18 +1029,17 @@ actually fully cloned." (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) @@ -952,11 +1047,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'. @@ -972,32 +1067,41 @@ 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." + (define (currying-lambda args doc-string? body) + (if (and (pair? args) + (pair? (car args))) + (currying-lambda (car args) doc-string? + `((lambda ,(cdr args) ,@body))) + (if doc-string? + `(lambda ,args ,doc-string? ,@body) + `(lambda ,args ,@body)))) + (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)))) + (if (pair? pred) + `(cons ,(car pred) + ,(and (pair? (cdr pred)) (cadr pred))) + pred)) + (cons type signature))) + + (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 ,@signature) + ,(currying-lambda args docstring (if docstring (cdr body) body))))) (defmacro-public define-music-function rest "Defining macro returning music functions. @@ -1013,10 +1117,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." @@ -1037,10 +1137,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." @@ -1069,10 +1165,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." @@ -1085,58 +1177,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) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1153,8 +1246,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)) @@ -1165,27 +1258,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 @@ -1203,9 +1296,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, @@ -1249,12 +1342,13 @@ 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)) + (cons 'rhythmic-event + (ly:parser-lookup parser '$chord-repeat-events)) + music)) + (lambda (music parser) (expand-repeat-notes! 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)) @@ -1267,7 +1361,7 @@ then revert skipTypesetting." (lambda (x parser) (skip-as-needed x parser) - ))) + ))) ;;;;;;;;;; ;;; general purpose music functions @@ -1275,9 +1369,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))) ;;;;;;;;;;;;;;;;; @@ -1286,10 +1380,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)) @@ -1311,70 +1405,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 @@ -1382,22 +1479,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. @@ -1414,10 +1511,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. @@ -1431,91 +1536,115 @@ 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:momentm p->p) music pitch) - (let* ((chord (make-event-chord - (map - (lambda (p) - (make-music 'NoteEvent - 'pitch p)) - pitches))) - (pitchout (begin - (ly:make-music-relative! chord pitch) - (event-chord-pitches chord)))) - (set! (ly:music-property music 'element) - (apply p->m pitchout)) - (apply p->p pitchout))) + (define ((make-relative::to-relative-callback variables music-call ref-call) + music pitch) + (let* ((ref-vars (map (lambda (v) + (if (ly:pitch? v) + (make-music 'NoteEvent 'pitch v) + (ly:music-deep-copy v))) + variables)) + (after-pitch (ly:make-music-relative! (apply ref-call ref-vars) pitch)) + (actual-vars (map (lambda (v r) + (if (ly:pitch? v) + (ly:music-property r 'pitch) + r)) + variables ref-vars)) + (rel-music (apply music-call actual-vars))) + (set! (ly:music-property music 'element) rel-music) + after-pitch)) `(make-music 'RelativeOctaveMusic 'to-relative-callback (,make-relative::to-relative-callback - (list ,@pitches) - (lambda ,pitches ,music) - (lambda ,pitches ,last-pitch)) + (list ,@variables) + (lambda ,variables ,music) + (lambda ,variables ,reference)) 'element ,music)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; The following functions are all associated with the crossStaff -; function + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The following functions are all associated with the crossStaff +;; function (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" @@ -1919,51 +2140,51 @@ base onto the following musical context." (define ((stem-connectable? ref root) stem) "Check if the stem is connectable to the root" - ; The root is always connectable to itself + ;; 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 'transparent) #t)) - 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 + (for-each (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)" (let ((span (ly:engraver-make-grob trans 'Stem '()))) (ly:grob-set-parent! span X root) (set! (ly:grob-object span 'stems) stems) - ; Suppress positioning, the stem code is confused by this weird stem + ;; Suppress positioning, the stem code is confused by this weird stem (set! (ly:grob-property span 'X-offset) 0) (set! (ly:grob-property span 'stencil) stem-span-stencil))) (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 @@ -1973,44 +2194,45 @@ other stems just because of that." (define (make-stem-spans! ctx stems trans) "Create stem spans for cross-staff stems" - ; Cannot do extensive checks here, just make sure there are at least - ; two stems at this musical moment + ;; 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))) + (for-each (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. -(define-public ((value-for-spanner-piece arg) grob) +(define ((value-for-spanner-piece arg) grob) "Associate a piece of broken spanner @var{grob} with an element 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)))) +(export value-for-spanner-piece) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; measure counter @@ -2025,49 +2247,355 @@ Broken measures are numbered in parentheses." (siblings (ly:spanner-broken-into orig)) ; have we been split? (bounds (ly:grob-array->list (ly:grob-object grob 'columns))) (refp (ly:grob-system grob)) - ; we use the first and/or last NonMusicalPaperColumn grob(s) of - ; a system in the event that a MeasureCounter spanner is broken + ;; we use the first and/or last NonMusicalPaperColumn grob(s) of + ;; 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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 + (lambda (x y) (coord-translate x y)) + arg offsets)) + (else arg))) + +(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 (self grob) + (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 + (if (procedure? target) + (target grob) + target)) + (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)))) + ; return the closure named `self' + self) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; \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)))))