X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=b1dc2f9c61391f32931e66b039561220af3e493c;hb=74daefdc62920b729061cb8711b63890de1f0c17;hp=490cafe92c40c9cc3f3de7ed20b29541353061ea;hpb=de451af43aef0220738bfdd5329f0685bdaba3d2;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 490cafe92c..b1dc2f9c61 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -1,11 +1,26 @@ -;;;; music-functions.scm -- +;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; source file of the GNU LilyPond music typesetter -;;;; -;;;; (c) 1998--2007 Jan Nieuwenhuizen +;;;; Copyright (C) 1998--2015 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys +;;;; +;;;; LilyPond is free software: you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation, either version 3 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; LilyPond is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with LilyPond. If not, see . -;; (use-modules (ice-9 optargs)) +;; 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) @@ -14,81 +29,107 @@ ;;; ==> 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!)) + +(define-public ly:grob-parent + (make-procedure-with-setter ly:grob-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!)) (define-public (music-map function music) "Apply @var{function} to @var{music} and all of the music it contains. -First it recurses over the children, then the function is applied to MUSIC. -" +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))) - (set! (ly:music-property music 'elements) - (map (lambda (y) (music-map function y)) es)) + (e (ly:music-property music 'element))) + (if (pair? 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 PRED." - - (define (inner-music-filter pred? music) + "Filter out music expressions that do not satisfy @var{pred?}." + + (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)))) - (set! (ly:music-property music 'element) filtered-e) - (set! (ly:music-property music 'elements) filtered-es) - (set! (ly:music-property music 'articulations) filtered-as) - ;; if filtering emptied the expression, we remove it completely. + (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)) + (if (not (null? es)) + (set! (ly:music-property music 'elements) filtered-es)) + (if (not (null? as)) + (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. - -(define-public (display-music music) - "Display music, not done with music-map for clarity of presentation." + (make-music 'Music))) ;must return music. - (display music) - (display ": { ") +(define*-public (display-music music #:optional (port (current-output-port))) + "Display music, not done with @code{music-map} for clarity of +presentation." + (display music port) + (display ": { " port) (let ((es (ly:music-property music 'elements)) - (e (ly:music-property music 'element))) - (display (ly:music-mutable-properties music)) + (e (ly:music-property music 'element))) + (display (ly:music-mutable-properties music) port) (if (pair? es) - (begin (display "\nElements: {\n") - (map display-music es) - (display "}\n"))) + (begin (display "\nElements: {\n" port) + (for-each (lambda (m) (display-music m port)) es) + (display "}\n" port))) (if (ly:music? e) - (begin - (display "\nChild:") - (display-music e)))) - (display " }\n") + (begin + (display "\nChild:" port) + (display-music e port)))) + (display " }\n" port) music) ;;; @@ -96,7 +137,7 @@ First it recurses over the children, then the function is applied to MUSIC. ;;; (define (markup-expression->make-markup markup-expression) "Transform `markup-expression' into an equivalent, hopefuly readable, scheme expression. -For instance, +For instance, \\markup \\bold \\italic hello ==> (markup #:line (#:bold (#:italic (#:simple \"hello\"))))" @@ -104,87 +145,93 @@ 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 - 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 `(markup ,@(inner-markup->make-markup markup-expression)))) (define-public (music->make-music obj) - "Generate a expression that, once evaluated, may return an object equivalent to `obj', -that is, for a music expression, a (make-music ...) form." + "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) - ,(car (ly:duration-factor obj)) - ,(cdr (ly:duration-factor 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))) "Displays `obj', typically a music expression, in a friendly fashion, -which often can be read back in order to generate an equivalent expression. - -Returns `obj'. -" +which often can be read back in order to generate an equivalent expression." (pretty-print (music->make-music obj) port) - (newline) - obj) + (newline port)) ;;; ;;; Scheme music expression --> Lily-syntax-using string translator @@ -192,77 +239,149 @@ Returns `obj'. (use-modules (srfi srfi-39) (scm display-lily)) -(define*-public (display-lily-music expr parser #: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)) - (newline))) + (*omit-duration* #f)) + (display (music->lily-string expr) port) + (newline port))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-public (shift-one-duration-log music shift dot) - " add SHIFT to duration-log of 'duration in music and optionally - a dot to any note encountered. This scales the music up by a factor - 2^shift * (2 - (1/2)^dot)" + "Add @var{shift} to @code{duration-log} of @code{'duration} in +@var{music} and optionally @var{dot} to any note encountered. +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-factor d)) - (nd (ly:make-duration (+ shift (ly:duration-log d)) - (+ dot (ly:duration-dot-count d)) - (car cp) - (cdr cp)))) - (set! (ly:music-property music 'duration) nd))) + (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))) + ;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 (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." + ;; 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* ((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 ((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 (equal? name "tremolo") - (let* ((dots (1- (logcount times))) - (mult (/ (* times (ash 1 dots)) (1- (ash 2 dots)))) - (shift (- (ly:intlog2 (floor mult))))) - (if (not (integer? mult)) - (ly:warning (_ "invalid tremolo repeat count: ~a") times)) - (if (memq 'sequential-music (ly:music-property main 'types)) - ;; \repeat "tremolo" { c4 d4 } - (let ((children (length (ly:music-property main 'elements)))) - - ;; fixme: should be more generic. - (if (and (not (= children 2)) - (not (= children 1))) - (ly:warning (_ "expecting 2 elements for chord tremolo, found ~a") children)) - (ly:music-compress r (ly:make-moment 1 children)) - (shift-duration-log r - (if (= children 2) (1- shift) shift) - dots)) - ;; \repeat "tremolo" c4 - (shift-duration-log r shift dots))) - r))) + "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}, +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))) + + (if (every (lambda (d) (equal? d first-dur)) durs) + (max (- (ly:duration-log first-dur) 2) 1) + 0))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; clusters. (define-public (note-to-cluster music) - "Replace NoteEvents by ClusterNoteEvents." + "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) @@ -271,79 +390,204 @@ Returns `obj'. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; repeats. -(define-public (unfold-repeats music) - " -This function replaces all repeats with unfold repeats. " - - (let ((es (ly:music-property music 'elements)) - (e (ly:music-property music 'element)) - ) - (if (memq 'repeated-music (ly:music-property music 'types)) - (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 (equal? old-name 'TremoloRepeatedMusic) - (let* ((seq-arg? (memq 'sequential-music - (ly:music-property e 'types))) - (count (ly:music-property music 'repeat-count)) - (dot-shift (if (= 0 (remainder count 3)) - -1 0))) - - (if (= 0 -1) - (set! count (* 2 (quotient count 3)))) - - (shift-duration-log music (+ (if seq-arg? 1 0) - (ly:intlog2 count)) dot-shift) - - (if seq-arg? - (ly:music-compress e (ly:make-moment (length (ly:music-property - e 'elements)) 1))))))) - - - (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 location + #:key + (start 0) + default + (min 1) + max) + "Check a grob path specification @var{path}, a symbol list (or a +single symbol), for validity and possibly complete it. Returns the +completed specification, or @code{#f} if invalid. If optional +@var{parser} is given, a syntax error is raised in that case, +optionally using @var{location}. If an optional keyword argument +@code{#:start @var{start}} is given, the parsing starts at the given +index in the sequence @samp{Context.Grob.property.sub-property...}, +with the default of @samp{0} implying the full path. + +If there is no valid first element of @var{path} fitting at the given +path location, an optionally given @code{#:default @var{default}} is +used as the respective element instead without checking it for +validity at this position. + +The resulting path after possibly prepending @var{default} can be +constrained in length by optional arguments @code{#:min @var{min}} and +@code{#:max @var{max}}, defaulting to @samp{1} and unlimited, +respectively." + (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 (unspecial? s) + (not (or (object-property s 'is-grob?) + (object-property s 'backend-type?)))) + (define (grob? s) + (object-property s 'is-grob?)) + (define (property? s) + (object-property s 'backend-type?)) + (define (check c p) (c p)) + + (let* ((checkers + (and (< start 3) + (drop (list unspecial? grob? property?) start))) + (res + (cond + ((null? path) + ;; tricky. Should we make use of the default when the + ;; list is empty? In most cases, this question should be + ;; academical as an empty list can only be generated by + ;; Scheme and is likely an error. We consider this a case + ;; of "no valid first element, and default given". + ;; Usually, invalid use cases should be caught later using + ;; the #:min argument, and if the user explicitly does not + ;; catch this, we just follow through. + (if default (list default) '())) + ((not checkers) + ;; no checkers, so we have a valid first element and just + ;; take the path as-is. + path) + (default + (if ((car checkers) (car path)) + (and (every check (cdr checkers) (cdr path)) + path) + (and (every check (cdr checkers) path) + (cons default path)))) + (else + (and (every check checkers path) + path))))) + (if (and res + (if max (<= min (length res) max) + (<= min (length res)))) + res + (begin + (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 Music expression that sets GPROP to VAL in 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 Music expression that sets GPROP to VAL in GROB. Does a pop first, -i.e. this is not an override" + "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 GPROP for GROB." + "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 - '(DotColumn + '(AccidentalSuggestion + DotColumn Dots Fingering LaissezVibrerTie + LigatureBracket + MultiMeasureRest PhrasingSlur RepeatTie Rest @@ -351,317 +595,471 @@ i.e. this is not an override" Slur Stem TextScript - Tie)) + Tie + 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 NoteHead font-size -3) - (Voice Dots font-size -3) - (Voice Stem length-fraction 0.8) - (Voice Stem no-stem-extend #t) - (Voice Beam thickness 0.384) - (Voice Beam length-fraction 0.8) - (Voice Accidental font-size -4))) - - (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) + (list + (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) - "Like context-spec-music, but only descending. " - (let ((cm (context-spec-music 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 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)) - -(define-public (make-ottava-set octavation) - (let ((m (make-music 'ApplyContext))) - (define (ottava-modify context) - "Either reset middleCPosition to the stored original, or remember -old middleCPosition, add OCTAVATION to middleCPosition, and set -OTTAVATION to `8va', or whatever appropriate." - (if (number? (ly:context-property context 'middleCOffset)) - (let ((where (ly:context-property-where-defined context 'middleCOffset))) - (ly:context-unset-property where 'middleCOffset) - (ly:context-unset-property where 'ottavation))) - - (let* ((offset (* -7 octavation)) - (string (cdr (assoc octavation '((2 . "15ma") - (1 . "8va") - (0 . #f) - (-1 . "8vb") - (-2 . "15mb")))))) - (ly:context-set-property! context 'middleCOffset offset) - (ly:context-set-property! context 'ottavation string) - (ly:set-middle-C! context))) - (set! (ly:music-property m 'procedure) ottava-modify) - (context-spec-music m 'Staff))) - -(define-public (set-octavation ottavation) - (ly:export (make-ottava-set ottavation))) - -(define-public (make-time-signature-set num den . rest) - "Set properties for time signature NUM/DEN. Rest can contain a list -of beat groupings " - - (define (standard-beat-grouping num den) - - "Some standard subdivisions for time signatures." - (let* - ((key (cons num den)) - (entry (assoc key '(((6 . 8) . (3 3)) - ((5 . 8) . (3 2)) - ((9 . 8) . (3 3 3)) - ((12 . 8) . (3 3 3 3)) - ((8 . 8) . (3 3 2)) - )))) - - (if entry - (cdr entry) - '()))) - - (let* ((set1 (make-property-set 'timeSignatureFraction (cons num den))) - (beat (ly:make-moment 1 den)) - (len (ly:make-moment num den)) - (set2 (make-property-set 'beatLength beat)) - (set3 (make-property-set 'measureLength len)) - (set4 (make-property-set 'beatGrouping (if (pair? rest) - (car rest) - (standard-beat-grouping num den)))) - (basic (list set1 set2 set3 set4))) - (descend-to-context - (context-spec-music (make-sequential-music basic) 'Timing) 'Score))) - -(define-public (make-mark-set label) - "Make the music for the \\mark command." - (let* ((set (if (integer? label) - (context-spec-music (make-property-set 'rehearsalMark label) - 'Score) - #f)) - (ev (make-music 'MarkEvent)) - (ch (make-event-chord (list ev)))) - (if set - (make-sequential-music (list set ch)) - (begin - (set! (ly:music-property ev 'label) label) - ch)))) - -(define-public (set-time-signature num den . rest) - (ly:export (apply make-time-signature-set `(,num ,den . ,rest)))) - -(define-safe-public (make-articulation name) - (make-music 'ArticulationEvent - 'articulation-type name)) + 'symbol sym)) + +(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) + (make-grob-property-override h '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) + (make-grob-property-revert h '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 +inside of and outside of chord construct." + ;; are we inside a <...>? + (if (eq? (ly:music-property music 'name) 'NoteEvent) + ;; yes -> use a tweak + (begin + (set! (ly:music-property music 'tweaks) + (acons 'style style (ly:music-property music 'tweaks))) + music) + ;; not in <...>, so use overrides + (make-sequential-music + (list + (override-head-style heads style) + music + (revert-head-style heads))))) (define-public (set-mus-properties! m alist) - "Set all of ALIST as properties of M." + "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 M a separator?" + "Is @var{m} a separator?" (let ((ts (ly:music-property m 'types))) (memq 'separator ts))) +;;; expanding repeat chords +(define-public (copy-repeat-chord original-chord repeat-chord duration + 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 +duration is replaced with the specified @var{duration}." + ;; First remove everything from event-types that can already be + ;; found in the repeated chord. We don't need to look for + ;; articulations on individual events since they can't actually get + ;; into a repeat chord given its input syntax. + + (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))) + '(elements articulations)) + + ;; now treat the elements + (set! (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)))) + (if (pair? arts) + (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) + "Walks through @var{music} and fills repeated chords (notable by +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)) + (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) "Make a list of Musics. - voicify-list :: [ [Music ] ] -> number -> [Music] - LST is a list music-lists. +voicify-list :: [ [Music ] ] -> number -> [Music] +LST is a list music-lists. - NUMBER is 0-base, i.e. Voice=1 (upstems) has number 0. +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)))) - 'Voice (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) - "Recursively split chords that are separated with \\ " + "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))) + (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) - (ly:export (make-music 'Music))) + (make-music 'Music)) -;; Make a function that checks score element for being of a specific type. +;; Make a function that checks score element for being of a specific type. (define-public (make-type-checker symbol) (lambda (elt) - ;;(display symbol) - ;;(eq? #t (ly:grob-property elt symbol)) - (not (eq? #f (memq symbol (ly:grob-property elt 'interfaces)))))) + (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) - "Usage: - -\\applyoutput #(set-output-property 'Clef 'extra-offset '(0 . 1)) - -" +(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? (cdr (assoc 'name meta)) grob-name) - (set! (ly:grob-property grob symbol) val)))) - - -;; -(define-public (smart-bar-check n) - "Make a bar check that checks for a specific bar number. -" - (let ((m (make-music 'ApplyContext))) - (define (checker tr) - (let* ((bn (ly:context-property tr 'currentBarNumber))) - (if (= bn n) - #t - (ly:error - ;; FIXME: uncomprehensable message - (_ "Bar check failed. Expect to be at ~a, instead at ~a") - n bn)))) - (set! (ly:music-property m 'procedure) checker) - m)) + (if (equal? (assoc-get 'name meta) grob-name) + (set! (ly:grob-property grob symbol) val)))) +(export set-output-property) (define-public (skip->rest mus) - - "Replace MUS by RestEvent of the same duration if it is a -SkipEvent. Useful for extracting parts from crowded scores" + "Replace @var{mus} by @code{RestEvent} of the same duration if it is a +@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 . rest) + (let ((ip (ly:music-property music 'origin))) + (if (ly:input-location? ip) + (apply ly:input-message ip msg rest) + (apply ly:message msg rest)))) -(define-public (ly:music-message music msg) +(define-public (ly:music-warning music msg . rest) (let ((ip (ly:music-property music 'origin))) (if (ly:input-location? ip) - (ly:input-message 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)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -671,127 +1069,253 @@ SkipEvent. Useful for extracting parts from crowded scores" (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)) (define (vector-map f v) - "Map F over V. This function returns nothing." + "Map F over V. This function returns nothing." (do ((n (vector-length v)) (i 0 (+ i 1))) ((>= i n)) (f (vector-ref v i)))) (define (vector-reverse-map f v) - "Map F over V, N to 0 order. This function returns nothing." + "Map F over V, N to 0 order. This function returns nothing." (do ((i (- (vector-length v) 1) (- i 1))) ((< i 0)) (f (vector-ref v i)))) (define-public (add-grace-property context-name grob sym val) - "Set SYM=VAL for GROB in CONTEXT-NAME. " + "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))) - (ly:export (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 SYM for GROB in CONTEXT-NAME. " + "Remove all @var{sym} for @var{grob} in @var{context-name}." (define (sym-grob-context? property sym grob context-name) (and (eq? (car property) context-name) (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)) - (prop-settings (filter - (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) + (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)) + (for-each (lambda(x) + (set! new-settings (delete x new-settings))) + prop-settings) (ly:context-set-property! where 'graceSettings new-settings))) - (ly:export (context-spec-music (make-apply-context delete-prop) 'Voice))) - + (make-apply-context delete-prop)) -(defmacro-public def-grace-function (start stop) - `(define-music-function (parser location music) (ly:music?) +(defmacro-public def-grace-function (start stop . docstring) + "Helper macro for defining grace 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-music-function (args signature . body) +(defmacro-public define-syntax-function (type args signature . body) "Helper macro for `ly:make-music-function'. Syntax: - (define-music-function (parser location arg1 arg2 ...) (arg1-type? arg2-type? ...) + (define-syntax-function result-type? (arg1 arg2 ...) (arg1-type arg2-type ...) ...function body...) -" - `(ly:make-music-function (list ,@signature) - (lambda (,@args) - ,@body))) +argX-type can take one of the forms @code{predicate?} for mandatory +arguments satisfying the predicate, @code{(predicate?)} for optional +parameters of that type defaulting to @code{#f}, @code{@w{(predicate? +value)}} for optional parameters with a specified default +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. + +@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 (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 (arg1 arg2 ...) (arg1-type? arg2-type? ...) + ...function body...) + +argX-type can take one of the forms @code{predicate?} for mandatory +arguments satisfying the predicate, @code{(predicate?)} for optional +parameters of that type defaulting to @code{#f}, @code{@w{(predicate? +value)}} for optional parameters with a specified default +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. + +Must return a music expression. The @code{origin} is automatically +set to the @code{location} parameter." + + `(define-syntax-function (ly:music? (make-music 'Music 'void #t)) ,@rest)) + + +(defmacro-public define-scheme-function rest + "Defining macro returning Scheme functions. +Syntax: + (define-scheme-function (arg1 arg2 ...) (arg1-type? arg2-type? ...) + ...function body...) + +argX-type can take one of the forms @code{predicate?} for mandatory +arguments satisfying the predicate, @code{(predicate?)} for optional +parameters of that type defaulting to @code{#f}, @code{@w{(predicate? +value)}} for optional parameters with a specified default +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. + +Can return arbitrary expressions. If a music expression is returned, +its @code{origin} is automatically set to the @code{location} +parameter." + + `(define-syntax-function scheme? ,@rest)) + +(defmacro-public define-void-function rest + "This defines a Scheme function like @code{define-scheme-function} with +void return value (i.e., what most Guile functions with `unspecified' +value return). Use this when defining functions for executing actions +rather than returning values, to keep Lilypond from trying to interpret +the return value." + `(define-syntax-function (void? *unspecified*) ,@rest *unspecified*)) + +(defmacro-public define-event-function rest + "Defining macro returning event functions. +Syntax: + (define-event-function (arg1 arg2 ...) (arg1-type? arg2-type? ...) + ...function body...) + +argX-type can take one of the forms @code{predicate?} for mandatory +arguments satisfying the predicate, @code{(predicate?)} for optional +parameters of that type defaulting to @code{#f}, @code{@w{(predicate? +value)}} for optional parameters with a specified default +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. + +Must return an event expression. The @code{origin} is automatically +set to the @code{location} parameter." + + `(define-syntax-function (ly:event? (make-music 'Event 'void #t)) ,@rest)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-public (cue-substitute quote-music) - "Must happen after quote-substitute." - + "Must happen after @code{quote-substitute}." + (if (vector? (ly:music-property quote-music 'quoted-events)) (let* ((dir (ly:music-property quote-music 'quoted-voice-direction)) - (main-voice (if (eq? 1 dir) 1 0)) - (cue-voice (if (eq? 1 dir) 0 1)) - (main-music (ly:music-property quote-music 'element)) - (return-value quote-music)) - - (if (or (eq? 1 dir) (eq? -1 dir)) - - ;; if we have stem dirs, change both quoted and main music - ;; to have opposite stems. - (begin - (set! return-value - - ;; cannot context-spec Quote-music, since context - ;; for the quotes is determined in the iterator. - (make-sequential-music - (list - (context-spec-music (make-voice-props-set cue-voice) 'CueVoice "cue") - quote-music - (context-spec-music (make-voice-props-revert) 'CueVoice "cue")))) - (set! main-music - (make-sequential-music - (list - (make-voice-props-set main-voice) - main-music - (make-voice-props-revert)))) - (set! (ly:music-property quote-music 'element) main-music))) - - return-value) + (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 (if (string? quoted-name) - (hash-ref quote-tab quoted-name #f) - #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:warning (_ "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) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -808,9 +1332,9 @@ Syntax: (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)) @@ -820,389 +1344,1342 @@ Syntax: (define (precompute-music-length music) (set! (ly:music-property music 'length) - (ly:music-length music)) + (ly:music-length music)) music) -(define (skip-to-last music parser) +(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))) +(define (make-skipped moment bool) + "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) "Replace MUSIC by - -<< { \\set skipTypesetting = ##t - LENGTHOF(\\showLastLength) - \\set skipTypesetting = ##t } - MUSIC >> - -if appropriate. - " + << { \\set skipTypesetting = ##f + LENGTHOF(\\showFirstLength) + \\set skipTypesetting = ##t + LENGTHOF(\\showLastLength) } + MUSIC >> + if appropriate. + + When only showFirstLength is set, + the 'length property of the music is + overridden to speed up compiling." (let* - ((show-last (ly:parser-lookup parser 'showLastLength))) - - (if (ly:music? show-last) - (let* - ((orig-length (ly:music-length music)) - (skip-length (ly:moment-sub orig-length (ly:music-length show-last)))) - - (make-simultaneous-music - (list - (make-sequential-music - (list - (context-spec-music (make-property-set 'skipTypesetting #t) - 'Score) - (make-music 'SkipMusic 'duration - (ly:make-duration - 0 0 - (ly:moment-main-numerator skip-length) - (ly:moment-main-denominator skip-length))) - (context-spec-music (make-property-set 'skipTypesetting #f) - 'Score))) - music))) - music))) - - -(define-public toplevel-music-functions + ((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))) + (show-first-length (and (ly:music? show-first) + (ly:music-length show-first))) + (orig-length (ly:music-length music))) + + ;;FIXME: if using either showFirst- or showLastLength, + ;; make sure that skipBars is not set. + + (cond + + ;; both properties may be set. + ((and show-first-length show-last-length) + (let + ((skip-length (ly:moment-sub orig-length show-last-length))) + (make-simultaneous-music + (list + (make-sequential-music + (list + (make-skipped skip-length #t) + ;; let's draw a separator between the beginning and the end + (context-spec-music (make-property-set 'whichBar "||") + 'Timing))) + (make-skipped show-first-length #f) + music)))) + + ;; we may only want to print the last length + (show-last-length + (let + ((skip-length (ly:moment-sub orig-length show-last-length))) + (make-simultaneous-music + (list + (make-skipped skip-length #t) + music)))) + + ;; we may only want to print the beginning; in this case + ;; only the first length will be processed (much faster). + (show-first-length + ;; the first length must not exceed the original length. + (if (ly:moment (* prev-alt this-alt) 0))) + (set! need-restore #t)))))) + + (cons need-restore need-accidental))) + +(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. + +@var{octaveness} is either @code{'same-octave} or @code{'any-octave} and +defines whether the rule should respond to accidental changes in other +octaves than the current. @code{'same-octave} is the normal way to typeset +accidentals -- an accidental is made if the alteration is different from the +last active pitch in the same octave. @code{'any-octave} looks at the last +active pitch in any octave. + +@var{laziness} states over how many bars an accidental should be remembered. +@code{0}@tie{}is the default -- accidental lasts over 0@tie{}bar lines, that +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 #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 entry in localKeySignature. The entry is either of the form - '(notename . alter) or '((octave . notename) . (alter barnum . measurepos))." - (if (number? (car entry)) - (car entry) - (cdar entry))) + "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. + +The @samp{cdr} of the entry is either a rational @code{alter} indicating +a key signature alteration, or of the form +@code{(alter . (barnum . measurepos))} indicating an alteration caused by +an accidental in music." + (if (pair? (car entry)) + (cdar entry) + (car entry))) (define (key-entry-octave entry) - "Return the octave of an entry in localKeySignature (or #f if the entry does not have - an octave)." + "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 localKeySignature (or #f if the entry does not - have a bar number)." - (and (pair? (car entry)) (caddr entry))) + "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 localKeySignature (or #f if the entry does - not have a measure position)." - (and (pair? (car entry)) (cdddr entry))) + "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." - (if (number? (car entry)) - (cdr entry) - (cadr entry))) + "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)) + 0)) (define-public (find-pitch-entry keysig pitch accept-global accept-local) - "Return the first entry in keysig that matches the pitch. - accept-global states whether key signature entries should be included. - accept-local states whether local accidentals should be included. - if no matching entry is found, #f is returned." - (if (pair? keysig) - (let* ((entry (car keysig)) - (entryoct (key-entry-octave entry)) - (entrynn (key-entry-notename entry)) - (oct (ly:pitch-octave pitch)) - (nn (ly:pitch-notename pitch))) - (if (and (equal? nn entrynn) - (or (and accept-global (equal? #f entryoct)) - (and accept-local (equal? oct entryoct)))) - entry - (find-pitch-entry (cdr keysig) pitch accept-global accept-local))) - #f)) + "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))))) (define-public (neo-modern-accidental-rule context pitch barnum measurepos) - "an accidental rule that typesets an accidental if it differs from the key signature - 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 notename" - (let* ((keysig (ly:context-property context 'localKeySignature)) - (entry (find-pitch-entry keysig pitch #t #t))) - (if (equal? #f entry) - (cons #f #f) - (let* ((global-entry (find-pitch-entry keysig pitch #t #f)) - (key-acc (if (equal? global-entry #f) - 0 - (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))))))))) + "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 '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))))))))) + +(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))) + +(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))))))))