1;;;; This file is part of LilyPond, the GNU music typesetter. 2;;;; 3;;;; Copyright (C) 1998--2021 Jan Nieuwenhuizen <janneke@gnu.org> 4;;;; Han-Wen Nienhuys <hanwen@xs4all.nl> 5;;;; 6;;;; LilyPond is free software: you can redistribute it and/or modify 7;;;; it under the terms of the GNU General Public License as published by 8;;;; the Free Software Foundation, either version 3 of the License, or 9;;;; (at your option) any later version. 10;;;; 11;;;; LilyPond is distributed in the hope that it will be useful, 12;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14;;;; GNU General Public License for more details. 15;;;; 16;;;; You should have received a copy of the GNU General Public License 17;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>. 18 19(use-modules (lily safe-utility-defs)) 20 21(use-modules (ice-9 optargs)) 22(use-modules (srfi srfi-11)) 23 24;;; ly:music-property with setter 25;;; (ly:music-property my-music 'elements) 26;;; ==> the 'elements property 27;;; (set! (ly:music-property my-music 'elements) value) 28;;; ==> set the 'elements property and return it 29(define-public ly:music-property 30 (make-procedure-with-setter ly:music-property 31 ly:music-set-property!)) 32 33(define-safe-public (music-is-of-type? mus type) 34 "Does @var{mus} belong to the music class @var{type}?" 35 (memq type (ly:music-property mus 'types))) 36 37(eval-early 38 (define-safe-public (music-type-predicate types) 39 "Return a predicate function that can be used for checking 40music to have one of the types listed in @var{types}." 41 (if (cheap-list? types) 42 (lambda (m) 43 (any (lambda (t) (music-is-of-type? m t)) types)) 44 (lambda (m) (music-is-of-type? m types))))) 45 46;; TODO move this 47(define-public ly:grob-property 48 (make-procedure-with-setter ly:grob-property 49 ly:grob-set-property!)) 50 51(define-public ly:grob-object 52 (make-procedure-with-setter ly:grob-object 53 ly:grob-set-object!)) 54 55(define-public ly:grob-parent 56 (make-procedure-with-setter ly:grob-parent 57 ly:grob-set-parent!)) 58 59(define-public ly:prob-property 60 (make-procedure-with-setter ly:prob-property 61 ly:prob-set-property!)) 62 63(define-public ly:context-property 64 (make-procedure-with-setter ly:context-property 65 ly:context-set-property!)) 66 67(define-public (music-selective-map descend? function music) 68 "Apply @var{function} recursively to @var{music}, but refrain 69from mapping subexpressions of music that does not satisfy 70@var{descend?}." 71 (define (worker m) 72 (music-selective-map descend? function m)) 73 (if (descend? music) 74 (let ((arts (ly:music-property music 'articulations)) 75 (es (ly:music-property music 'elements)) 76 (e (ly:music-property music 'element))) 77 (if (pair? es) 78 (set! (ly:music-property music 'elements) 79 (map worker es))) 80 (if (pair? arts) 81 (set! (ly:music-property music 'articulations) 82 (map worker arts))) 83 (if (ly:music? e) 84 (set! (ly:music-property music 'element) 85 (worker e))))) 86 (recompute-music-length (function music))) 87 88(define-public (music-map function music) 89 "Apply @var{function} to @var{music} and all of the music it contains. 90 91First it recurses over the children, then the function is applied to 92@var{music}." 93 (music-selective-map ly:music? function music)) 94 95(define-public (music-selective-filter descend? pred? music) 96 "Recursively filter out music expressions that do not satisfy 97 @var{pred?}, but refrain from filtering the subexpressions of 98 music that does not satisfy @var{descend?}." 99 100 (define (inner-music-filter music) 101 "Recursive function." 102 (if (not (descend? music)) 103 (if (not (pred? music)) 104 (set! music '())) 105 (let* ((es (ly:music-property music 'elements)) 106 (e (ly:music-property music 'element)) 107 (as (ly:music-property music 'articulations)) 108 (filtered-as (filter ly:music? (map inner-music-filter as))) 109 (filtered-e (if (ly:music? e) 110 (inner-music-filter e) 111 e)) 112 (filtered-es (filter ly:music? (map inner-music-filter es)))) 113 (if (not (null? e)) 114 (set! (ly:music-property music 'element) filtered-e)) 115 (if (not (null? es)) 116 (set! (ly:music-property music 'elements) filtered-es)) 117 (if (not (null? as)) 118 (set! (ly:music-property music 'articulations) filtered-as)) 119 ;; if filtering invalidated 'element, we remove the music unless 120 ;; there are remaining 'elements in which case we just hope and 121 ;; pray. 122 (if (or (not (pred? music)) 123 (and (null? filtered-es) 124 (not (ly:music? filtered-e)) 125 (ly:music? e))) 126 (set! music '())) 127 (if (ly:music? music) 128 (recompute-music-length music)))) 129 music) 130 131 (set! music (inner-music-filter music)) 132 (if (ly:music? music) 133 music 134 (make-music 'Music))) ;must return music. 135 136(define-public (music-filter pred? music) 137 "Filter out music expressions that do not satisfy @var{pred?}." 138 (music-selective-filter ly:music? pred? music)) 139 140(define*-public (display-music music #:optional (port (current-output-port))) 141 "Display @var{music}, not done with @code{music-map} for clarity of 142presentation." 143 (display music port) 144 (display ": { " port) 145 (let ((es (ly:music-property music 'elements)) 146 (e (ly:music-property music 'element))) 147 (display (ly:music-mutable-properties music) port) 148 (if (pair? es) 149 (begin (display "\nElements: {\n" port) 150 (for-each (lambda (m) (display-music m port)) es) 151 (display "}\n" port))) 152 (if (ly:music? e) 153 (begin 154 (display "\nChild:" port) 155 (display-music e port)))) 156 (display " }\n" port) 157 music) 158 159;;; 160;;; A scheme music pretty printer 161;;; 162(define (markup-expression->make-markup markup-expression) 163 "Transform `markup-expression' into an equivalent, hopefuly readable, scheme expression. 164For instance, 165 \\markup \\bold \\italic hello 166==> 167 (markup #:line (#:bold (#:italic (#:simple \"hello\"))))" 168 (define (proc->command-keyword proc) 169 "Return a keyword, eg. `#:bold', from the `proc' function, eg. #<procedure bold-markup (layout props arg)>" 170 (let ((cmd-markup (symbol->string (procedure-name proc)))) 171 (symbol->keyword (string->symbol (substring cmd-markup 0 (- (string-length cmd-markup) 172 (string-length "-markup"))))))) 173 (define (transform-arg arg) 174 (cond ((and (pair? arg) (markup? (car arg))) ;; a markup list 175 (append-map inner-markup->make-markup arg)) 176 ((and (not (string? arg)) (markup? arg)) ;; a markup 177 (inner-markup->make-markup arg)) 178 (else ;; scheme arg 179 (music->make-music arg)))) 180 (define (inner-markup->make-markup mrkup) 181 (if (string? mrkup) 182 `(#:simple ,mrkup) 183 (let ((cmd (proc->command-keyword (car mrkup))) 184 (args (map transform-arg (cdr mrkup)))) 185 `(,cmd ,@args)))) 186 ;; body: 187 (if (string? markup-expression) 188 markup-expression 189 `(markup ,@(inner-markup->make-markup markup-expression)))) 190 191(define-public (music->make-music obj) 192 "Generate an expression that, once evaluated, may return an object 193equivalent to @var{obj}, that is, for a music expression, a 194@code{(make-music ...)} form." 195 (define (if-nonzero num) 196 (if (zero? num) '() (list num))) 197 (cond (;; markup expression 198 (markup? obj) 199 (markup-expression->make-markup obj)) 200 (;; music expression 201 (ly:music? obj) 202 `(make-music 203 ',(ly:music-property obj 'name) 204 ,@(append-map (lambda (prop) 205 `(',(car prop) 206 ,(music->make-music (cdr prop)))) 207 (remove (lambda (prop) 208 (eqv? (car prop) 'origin)) 209 (ly:music-mutable-properties obj))))) 210 (;; moment 211 (ly:moment? obj) 212 `(ly:make-moment 213 ,@(let ((main (ly:moment-main obj)) 214 (grace (ly:moment-grace obj))) 215 (cond ((zero? grace) (list main)) 216 ((negative? grace) (list main grace)) 217 (else ;;positive grace requires 4-arg form 218 (list (numerator main) 219 (denominator main) 220 (numerator grace) 221 (denominator grace))))))) 222 (;; note duration 223 (ly:duration? obj) 224 `(ly:make-duration ,(ly:duration-log obj) 225 ,@(if (= (ly:duration-scale obj) 1) 226 (if-nonzero (ly:duration-dot-count obj)) 227 (list (ly:duration-dot-count obj) 228 (ly:duration-scale obj))))) 229 (;; note pitch 230 (ly:pitch? obj) 231 `(ly:make-pitch ,(ly:pitch-octave obj) 232 ,(ly:pitch-notename obj) 233 ,@(if-nonzero (ly:pitch-alteration obj)))) 234 (;; scheme procedure 235 (procedure? obj) 236 (or (procedure-name obj) obj)) 237 (;; a symbol (avoid having an unquoted symbol) 238 (symbol? obj) 239 `',obj) 240 (;; an empty list (avoid having an unquoted empty list) 241 (null? obj) 242 `'()) 243 (;; a proper list 244 (list? obj) 245 `(list ,@(map music->make-music obj))) 246 (;; a pair 247 (pair? obj) 248 `(cons ,(music->make-music (car obj)) 249 ,(music->make-music (cdr obj)))) 250 (else 251 obj))) 252 253(use-modules (ice-9 pretty-print)) 254(define*-public (display-scheme-music obj #:optional (port (current-output-port))) 255 "Display @var{obj}, typically a music expression, in a friendly fashion, 256which often can be read back in order to generate an equivalent expression." 257 (pretty-print (music->make-music obj) port) 258 (newline port)) 259 260;;; 261;;; Scheme music expression --> Lily-syntax-using string translator 262;;; 263(use-modules (srfi srfi-39) 264 (lily display-lily)) 265 266(define*-public (display-lily-music expr #:optional (port (current-output-port))) 267 "Display the music expression @var{expr} using LilyPond syntax." 268 (memoize-clef-names supported-clefs) 269 (parameterize ((*indent* 0) 270 (*omit-duration* #f)) 271 (display (music->lily-string expr) port) 272 (newline port))) 273 274;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 275 276(define-public (shift-one-duration-log music shift dot) 277 "Add @var{shift} to @code{duration-log} of @code{'duration} in 278@var{music} and optionally @var{dot} to any note encountered. 279The number of dots in the shifted music may not be less than zero." 280 (let ((d (ly:music-property music 'duration))) 281 (if (ly:duration? d) 282 (let* ((cp (ly:duration-scale d)) 283 (nd (ly:make-duration 284 (+ shift (ly:duration-log d)) 285 (max 0 (+ dot (ly:duration-dot-count d))) 286 cp))) 287 (set! (ly:music-property music 'duration) nd))) 288 ;; clear cached length, since it's no longer valid 289 (set! (ly:music-property music 'length) '()) 290 music)) 291 292(define-public (shift-duration-log music shift dot) 293 (music-map (lambda (x) (shift-one-duration-log x shift dot)) 294 music)) 295 296(define-safe-public (volta-spec-music number-list music) 297 "Add \\volta @var{number-list} to @var{music}." 298 (make-music 'VoltaSpeccedMusic 299 'element music 300 'volta-numbers number-list)) 301 302(define-public (make-repeat name times main alts) 303 "Create a repeat music expression, with all properties initialized 304properly." 305 (let* ((sane-times (max times 1)) ; TODO: Warn? 306 (type (or (assoc-get name '(("volta" . VoltaRepeatedMusic) 307 ("unfold" . UnfoldedRepeatedMusic) 308 ("percent" . PercentRepeatedMusic) 309 ("tremolo" . TremoloRepeatedMusic))) 310 (begin (ly:warning (_ "unknown repeat type `~S': \ 311must be volta, unfold, percent, or tremolo") name) 312 'VoltaRepeatedMusic))) 313 (alt-music 314 (if (ly:music? alts) 315 (begin 316 ;; TODO: Consider accepting plain sequential-music, 317 ;; which would allow this: 318 ;; 319 ;; alts = { a b } % note no \alternative here 320 ;; \repeat volta 2 {} \alternative \alts 321 ;; 322 (if (not (music-is-of-type? alts 'sequential-alternative-music)) 323 (ly:music-warning alts (_ "alternative music expected"))) 324 alts) 325 ;; Accept a bare element list for backward compatibility. 326 (make-music 'SequentialAlternativeMusic 327 'elements alts 328 'origin (ly:music-property main 'origin))))) 329 330 ;; If the user did not specify volta numbers, wrap the 331 ;; alternatives for consistency with the legacy behavior. 332 (define (elaborate-alternative-music alt-music times) 333 (let* ((alts (ly:music-property alt-music 'elements)) 334 (lalts (length alts)) 335 (talts (if (< times lalts) 336 (let ((message (_ "More alternatives than repeats. \ 337Junking excess alternatives"))) 338 ;; The \repeat and \the alternative are not 339 ;; necessarily close together in the source. 340 ;; Warn twice to point to both. 341 (ly:music-warning main message) 342 (ly:music-warning alt-music message) 343 (set! lalts times) 344 (take alts times)) 345 alts))) 346 347 (define (is-specced music) 348 (music-is-of-type? music 'volta-specification)) 349 350 (if (not (any is-specced alts)) 351 (let* ((alt-1-count (1+ (- times lalts))) 352 ;; volta numbers for each alternative (list of lists) 353 (volta-numbers (cons 354 (map 1+ (iota alt-1-count)) 355 (map (lambda (i) (list (+ alt-1-count 1 i))) 356 (iota (- times 1)))))) 357 ;; wrap the alternatives and set their volta numbers 358 (set! talts (map volta-spec-music volta-numbers talts)))) 359 (make-music 'SequentialAlternativeMusic 360 'elements talts))) 361 362 (define (pass-over-repeated-music music) 363 (not (music-is-of-type? music 'repeated-music))) 364 365 (define (map-alternatives m) 366 (if (music-is-of-type? m 'sequential-alternative-music) 367 (elaborate-alternative-music m sane-times) 368 m)) 369 370 (make-music type 371 'element (music-selective-map 372 pass-over-repeated-music 373 map-alternatives 374 main) 375 'repeat-count sane-times 376 'elements 377 (ly:music-property 378 (elaborate-alternative-music alt-music sane-times) 379 'elements)))) 380 381(define (calc-repeat-slash-count music) 382 "Given the child-list @var{music} in @code{PercentRepeatMusic}, 383calculate the number of slashes based on the durations. Returns @code{0} 384if durations in @var{music} vary, allowing slash beats and double-percent 385beats to be distinguished." 386 (let* ((durs (map duration-of-note 387 (extract-named-music music '(EventChord NoteEvent 388 RestEvent SkipEvent)))) 389 (first-dur (car durs))) 390 391 (if (every (lambda (d) (equal? d first-dur)) durs) 392 (max (- (ly:duration-log first-dur) 2) 1) 393 0))) 394 395;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 396;; clusters. 397 398(define-public (note-to-cluster music) 399 "Replace @code{NoteEvents} by @code{ClusterNoteEvents}." 400 (if (eq? (ly:music-property music 'name) 'NoteEvent) 401 (make-music 'ClusterNoteEvent 402 'pitch (ly:music-property music 'pitch) 403 'duration (ly:music-property music 'duration)) 404 music)) 405 406(define-public (notes-to-clusters music) 407 (music-map note-to-cluster music)) 408 409;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 410;; repeats. 411 412(define-public (unfold-repeats types music) 413 "Replace repeats of the types given by @var{types} with unfolded repeats. 414If @var{types} is an empty list, @code{repeated-music} is taken, unfolding all." 415 (let* ((types-list 416 (if (or (null? types) (not (list? types))) 417 (list types) 418 types)) 419 (repeat-types-alist 420 '((volta . volta-repeated-music) 421 (percent . percent-repeated-music) 422 (tremolo . tremolo-repeated-music) 423 (() . repeated-music))) 424 (repeat-types-hash (alist->hash-table repeat-types-alist))) 425 (for-each 426 (lambda (type) 427 (let ((repeat-type (hashq-ref repeat-types-hash type))) 428 (if repeat-type 429 (let ((es (ly:music-property music 'elements)) 430 (e (ly:music-property music 'element))) 431 (if (music-is-of-type? music repeat-type) 432 (set! music (make-music 'UnfoldedRepeatedMusic music))) 433 (if (pair? es) 434 (set! (ly:music-property music 'elements) 435 (map (lambda (x) (unfold-repeats types x)) es))) 436 (if (ly:music? e) 437 (set! (ly:music-property music 'element) 438 (unfold-repeats types e)))) 439 (ly:warning (_ "unknown repeat-type ~a, ignoring.") type)))) 440 types-list) 441 music)) 442 443(define-public (unfold-repeats-fully music) 444 "Unfold repeats and expand the resulting @code{unfolded-repeated-music}." 445 (map-some-music 446 (lambda (m) 447 (and (music-is-of-type? m 'unfolded-repeated-music) 448 (make-sequential-music 449 (ly:music-deep-copy (make-unfolded-set m))))) 450 (unfold-repeats '() music))) 451 452;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 453;; property setting music objs. 454 455;; Can't use define* behavior since Guile-1.8 has a bug when combining 456;; #:optional with #:key and leaving optional args off. 457(define-safe-public (check-grob-path path . rest) 458 "Check a grob path specification @var{path}, a symbol list (or a 459single symbol), for validity and possibly complete it. Returns the 460completed specification, or @code{#f} if invalid, optionally using 461@var{location} for an error message. If an optional keyword argument 462@code{#:start @var{start}} is given, the parsing starts at the given 463index in the sequence @samp{Context.@/Grob.@/property.@/sub-property...}, 464with the default of @samp{0} implying the full path. 465 466If there is no valid first element of @var{path} fitting at the given 467path location, an optionally given @code{#:default @var{default}} is 468used as the respective element instead without checking it for 469validity at this position. 470 471The resulting path after possibly prepending @var{default} can be 472constrained in length by optional arguments @code{#:min @var{min}} and 473@code{#:max @var{max}}, defaulting to @samp{1} and unlimited, 474respectively." 475 (define (unspecial? s) 476 (not (or (object-property s 'is-grob?) 477 (object-property s 'backend-type?)))) 478 (define (grob? s) 479 (object-property s 'is-grob?)) 480 (define (property? s) 481 (object-property s 'backend-type?)) 482 (define (check c p) (c p)) 483 (let-keywords 484 (if (or (null? rest) (keyword? (car rest))) 485 rest 486 (cdr rest)) 487 #f 488 ((start 0) 489 default 490 (min 1) 491 max) 492 (let* ((path (if (symbol? path) (list path) path)) 493 (location (and (pair? rest) (not (keyword? (car rest))) 494 (car rest))) 495 (checkers 496 (and (< start 3) 497 (drop (list unspecial? grob? property?) start))) 498 (res 499 (cond 500 ((null? path) 501 ;; tricky. Should we make use of the default when the 502 ;; list is empty? In most cases, this question should be 503 ;; academical as an empty list can only be generated by 504 ;; Scheme and is likely an error. We consider this a case 505 ;; of "no valid first element, and default given". 506 ;; Usually, invalid use cases should be caught later using 507 ;; the #:min argument, and if the user explicitly does not 508 ;; catch this, we just follow through. 509 (if default (list default) '())) 510 ((not checkers) 511 ;; no checkers, so we have a valid first element and just 512 ;; take the path as-is. 513 path) 514 (default 515 (if ((car checkers) (car path)) 516 (and (every check (cdr checkers) (cdr path)) 517 path) 518 (and (every check (cdr checkers) path) 519 (cons default path)))) 520 (else 521 (and (every check checkers path) 522 path))))) 523 (if (and res 524 (if max (<= min (length res) max) 525 (<= min (length res)))) 526 res 527 (begin 528 (ly:parser-error 529 (format #f (_ "bad grob property path ~a") 530 path) 531 location) 532 #f))))) 533 534(define-safe-public (check-context-path path #:optional location) 535 "Check a context property path specification @var{path}, a symbol 536list (or a single symbol), for validity and possibly complete it. 537Returns the completed specification, or @code{#f} when rising an 538error (using optionally @var{location})." 539 (let* ((path (if (symbol? path) (list path) path))) 540 ;; A Guile 1.x bug specific to optargs precludes moving the 541 ;; defines out of the let 542 (define (property? s) 543 (object-property s 'translation-type?)) 544 (define (unspecial? s) 545 (not (property? s))) 546 (define (check c p) (c p)) 547 (or (case (length path) 548 ((1) (and (property? (car path)) (cons 'Bottom path))) 549 ((2) (and (unspecial? (car path)) (property? (cadr path)) path)) 550 (else #f)) 551 (begin 552 (ly:parser-error 553 (format #f (_ "bad context property ~a") 554 path) 555 location) 556 #f)))) 557 558;; Cannot use #:optional and #:key at the same time because of Guile 559;; bug in version 1.8 560(define-safe-public (check-music-path path . rest) 561 "Check a music property path specification @var{path}, a symbol 562list (or a single symbol), for validity and possibly complete it. 563Returns the completed specification, or @code{#f} when rising an 564error (using optionally @var{location})." 565 (define (property? s) 566 (object-property s 'music-type?)) 567 (define (unspecial? s) 568 (not (property? s))) 569 (let-keywords 570 (if (or (null? rest) (keyword? (car rest))) 571 rest 572 (cdr rest)) 573 #f 574 (default) 575 (let* ((path (if (symbol? path) (list path) path)) 576 (location (and (pair? rest) (not (keyword? (car rest))) 577 (car rest)))) 578 (or (case (length path) 579 ((1) (and (property? (car path)) (cons default path))) 580 ((2) (and (unspecial? (car path)) (property? (cadr path)) path)) 581 (else #f)) 582 (begin 583 (ly:parser-error 584 (format #f (_ "bad music property ~a") 585 path) 586 location) 587 #f))))) 588 589(define-public (make-grob-property-set grob gprop val) 590 "Make a @code{Music} expression that overrides a @var{gprop} to 591@var{val} in @var{grob}. Does a pop first, i.e., this is not a 592@code{\\temporary \\override}." 593 (make-music 'OverrideProperty 594 'symbol grob 595 'grob-property gprop 596 'grob-value val 597 'pop-first #t)) 598 599(define-public (make-grob-property-override grob gprop val) 600 "Make a @code{Music} expression that overrides @var{gprop} to 601@var{val} in @var{grob}. This is a @code{\\temporary \\override}, 602making it possible to @code{\\revert} to any previous value afterwards." 603 (make-music 'OverrideProperty 604 'symbol grob 605 'grob-property gprop 606 'grob-value val)) 607 608(define-public (make-grob-property-revert grob gprop) 609 "Revert the grob property @var{gprop} for @var{grob}." 610 (make-music 'RevertProperty 611 'symbol grob 612 'grob-property gprop)) 613 614(define direction-polyphonic-grobs 615 '(AccidentalSuggestion 616 DotColumn 617 Dots 618 Fingering 619 LaissezVibrerTie 620 LigatureBracket 621 MultiMeasureRest 622 PhrasingSlur 623 RepeatTie 624 Rest 625 Script 626 Slur 627 Stem 628 TextScript 629 Tie 630 TupletBracket 631 TrillSpanner)) 632 633(define general-grace-settings 634 `((Voice Stem font-size -3) 635 (Voice Flag font-size -3) 636 (Voice NoteHead font-size -3) 637 (Voice TabNoteHead font-size -4) 638 (Voice Dots font-size -3) 639 (Voice Stem length-fraction 0.8) 640 (Voice Stem no-stem-extend #t) 641 (Voice Beam beam-thickness 0.384) 642 (Voice Beam length-fraction 0.8) 643 (Voice Accidental font-size -4) 644 (Voice AccidentalCautionary font-size -4) 645 (Voice Script font-size -3) 646 (Voice Fingering font-size -8) 647 (Voice StringNumber font-size -8))) 648 649(define-public score-grace-settings 650 (append 651 `((Voice Stem direction ,UP) 652 (Voice Slur direction ,DOWN)) 653 general-grace-settings)) 654 655;; Getting a unique context id name 656 657(define-session unique-counter -1) 658(define-safe-public (get-next-unique-voice-name) 659 (set! unique-counter (1+ unique-counter)) 660 (format #f "uniqueContext~s" unique-counter)) 661 662 663(define-safe-public (make-voice-props-set n) 664 (make-sequential-music 665 (append 666 (map (lambda (x) (make-grob-property-set x 'direction 667 (if (odd? n) -1 1))) 668 direction-polyphonic-grobs) 669 (list 670 (make-property-set 'graceSettings general-grace-settings) 671 (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2)))))) 672 673(define-safe-public (make-voice-props-override n) 674 (make-sequential-music 675 (append 676 (map (lambda (x) (make-grob-property-override x 'direction 677 (if (odd? n) -1 1))) 678 direction-polyphonic-grobs) 679 (list 680 (make-property-set 'graceSettings general-grace-settings) 681 (make-grob-property-override 'NoteColumn 'horizontal-shift (quotient n 2)))))) 682 683(define-safe-public (make-voice-props-revert) 684 (make-sequential-music 685 (append 686 (map (lambda (x) (make-grob-property-revert x 'direction)) 687 direction-polyphonic-grobs) 688 (list (make-property-unset 'graceSettings) 689 (make-grob-property-revert 'NoteColumn 'horizontal-shift))))) 690 691 692(define-safe-public (context-spec-music m context #:optional id mods) 693 "Add @code{\\context @var{context} = @var{id} \\with @var{mods}} to @var{m}." 694 (let ((cm (make-music 'ContextSpeccedMusic 695 'element m 696 'context-type context))) 697 (if (string? id) 698 (set! (ly:music-property cm 'context-id) id)) 699 (if mods 700 (set! (ly:music-property cm 'property-operations) 701 (if (ly:context-mod? mods) 702 (ly:get-context-mods mods) 703 mods))) 704 cm)) 705 706(define-safe-public (descend-to-context m context #:optional id mods) 707 "Like @code{context-spec-music}, but only descending." 708 (let ((cm (context-spec-music m context id mods))) 709 (ly:music-set-property! cm 'search-direction DOWN) 710 cm)) 711 712(define-public (make-non-relative-music mus) 713 (make-music 'UnrelativableMusic 714 'element mus)) 715 716(define-public (make-apply-context func) 717 (make-music 'ApplyContext 718 'procedure func)) 719 720(define-public (make-sequential-music elts) 721 (make-music 'SequentialMusic 722 'elements elts)) 723 724(define-public (make-simultaneous-music elts) 725 (make-music 'SimultaneousMusic 726 'elements elts)) 727 728(define-safe-public (make-event-chord elts) 729 (make-music 'EventChord 730 'elements elts)) 731 732(define-public (make-skip-music dur) 733 (make-music 'SkipMusic 734 'duration dur)) 735 736(define-public (make-grace-music music) 737 (make-music 'GraceMusic 738 'element music)) 739 740;;;;;;;;;;;;;;;; 741 742;; mmrest 743(define-public (make-multi-measure-rest duration location) 744 (make-music 'MultiMeasureRestMusic 745 'origin location 746 'duration duration)) 747 748(define-public (make-property-set sym val) 749 (make-music 'PropertySet 750 'symbol sym 751 'value val)) 752 753(define-public (make-property-unset sym) 754 (make-music 'PropertyUnset 755 'symbol sym)) 756 757(define-safe-public (make-articulation name . properties) 758 (apply make-music 'ArticulationEvent 759 'articulation-type name 760 properties)) 761 762(define-public (make-lyric-event string duration) 763 (make-music 'LyricEvent 764 'duration duration 765 'text string)) 766 767(define-safe-public (make-span-event type span-dir) 768 (make-music type 769 'span-direction span-dir)) 770 771(define-public (override-head-style heads style) 772 "Override style for @var{heads} to @var{style}." 773 (make-sequential-music 774 (if (pair? heads) 775 (map (lambda (h) 776 (make-grob-property-override h 'style style)) 777 heads) 778 (list (make-grob-property-override heads 'style style))))) 779 780(define-public (revert-head-style heads) 781 "Revert style for @var{heads}." 782 (make-sequential-music 783 (if (pair? heads) 784 (map (lambda (h) 785 (make-grob-property-revert h 'style)) 786 heads) 787 (list (make-grob-property-revert heads 'style))))) 788 789(define-public (style-note-heads heads style music) 790 "Set @var{style} for all @var{heads} in @var{music}. Works both 791inside of and outside of chord construct." 792 ;; are we inside a <...>? 793 (if (eq? (ly:music-property music 'name) 'NoteEvent) 794 ;; yes -> use a tweak 795 (begin 796 (set! (ly:music-property music 'tweaks) 797 (acons 'style style (ly:music-property music 'tweaks))) 798 music) 799 ;; not in <...>, so use overrides 800 (make-sequential-music 801 (list 802 (override-head-style heads style) 803 music 804 (revert-head-style heads))))) 805 806(define-public (get-tweakable-music mus) 807 "When tweaking music, return a list of music expressions where the 808tweaks should be applied. Relevant for music wrappers and event 809chords." 810 (cond ((music-is-of-type? mus 'music-wrapper-music) 811 (get-tweakable-music (ly:music-property mus 'element))) 812 ((music-is-of-type? mus 'event-chord) 813 (filter (music-type-predicate 'rhythmic-event) 814 (ly:music-property mus 'elements))) 815 (else (list mus)))) 816 817(define-public (set-mus-properties! m alist) 818 "Set all of @var{alist} as properties of @var{m}." 819 (if (pair? alist) 820 (begin 821 (set! (ly:music-property m (caar alist)) (cdar alist)) 822 (set-mus-properties! m (cdr alist))))) 823 824(define-public (music-separator? m) 825 "Is @var{m} a separator?" 826 (let ((ts (ly:music-property m 'types))) 827 (memq 'separator ts))) 828 829;;; expanding repeat chords 830(define-public (copy-repeat-chord original-chord repeat-chord duration 831 event-types) 832 "Copy all events in @var{event-types} (be sure to include 833@code{rhythmic-events}) from @var{original-chord} over to 834@var{repeat-chord} with their articulations filtered as well. Any 835duration is replaced with the specified @var{duration}." 836 ;; First remove everything from event-types that can already be 837 ;; found in the repeated chord. We don't need to look for 838 ;; articulations on individual events since they can't actually get 839 ;; into a repeat chord given its input syntax. 840 841 (define keep-element? (music-type-predicate event-types)) 842 843 (for-each 844 (lambda (field) 845 (for-each (lambda (e) 846 (for-each (lambda (x) 847 (set! event-types (delq x event-types))) 848 (ly:music-property e 'types))) 849 (ly:music-property repeat-chord field))) 850 '(elements articulations)) 851 852 ;; now treat the elements 853 (set! (ly:music-property repeat-chord 'elements) 854 (let ((elts 855 (ly:music-deep-copy (filter keep-element? 856 (ly:music-property original-chord 857 'elements)) 858 repeat-chord))) 859 (for-each 860 (lambda (m) 861 (let ((arts (ly:music-property m 'articulations))) 862 (if (pair? arts) 863 (set! (ly:music-property m 'articulations) 864 (ly:set-origin! (filter! keep-element? arts) 865 repeat-chord))) 866 (if (ly:duration? (ly:music-property m 'duration)) 867 (set! (ly:music-property m 'duration) duration)) 868 (if (ly:music-property m 'cautionary #f) 869 (set! (ly:music-property m 'cautionary) #f)) 870 (if (ly:music-property m 'force-accidental #f) 871 (set! (ly:music-property m 'force-accidental) #f)))) 872 elts) 873 (append! elts (ly:music-property repeat-chord 'elements)))) 874 (let ((arts (filter keep-element? 875 (ly:music-property original-chord 876 'articulations)))) 877 (if (pair? arts) 878 (set! (ly:music-property repeat-chord 'articulations) 879 (append! 880 (ly:music-deep-copy arts repeat-chord) 881 (ly:music-property repeat-chord 'articulations))))) 882 repeat-chord) 883 884 885(define-public (expand-repeat-chords! event-types music) 886 "Walk through @var{music} and fill repeated chords (notable by 887having a duration in @code{duration}) with the notes from their 888respective predecessor chord." 889 (let loop ((music music) (last-chord #f)) 890 (if (music-is-of-type? music 'event-chord) 891 (let ((chord-repeat (ly:music-property music 'duration))) 892 (cond 893 ((not (ly:duration? chord-repeat)) 894 (if (any (lambda (m) (ly:duration? 895 (ly:music-property m 'duration))) 896 (ly:music-property music 'elements)) 897 music 898 last-chord)) 899 (last-chord 900 (set! (ly:music-property music 'duration) '()) 901 (copy-repeat-chord last-chord music chord-repeat event-types)) 902 (else 903 (ly:music-warning music (_ "Bad chord repetition")) 904 #f))) 905 (let ((elt (ly:music-property music 'element))) 906 (fold loop (if (ly:music? elt) (loop elt last-chord) last-chord) 907 (ly:music-property music 'elements))))) 908 music) 909 910;;; This does _not_ copy any articulations. Rationale: one main 911;;; incentive for pitch-repeating durations is after ties, such that 912;;; 4~2~8. can stand in for a 15/16 note in \partial 4 position. In 913;;; this use case, any repeated articulations will be a nuisance. 914;;; 915;;; String assignments in TabStaff might seem like a worthwhile 916;;; exception, but they would be better tackled by the respective 917;;; engravers themselves (see issue 3662). 918;;; 919;;; Repeating chords as well seems problematic for things like 920;;; \score { 921;;; << 922;;; \new Staff { c4 c c <c e> } 923;;; \new RhythmicStaff { 4 4 4 4 } 924;;; >> 925;;; } 926;;; 927;;; However, because of MIDI it is not advisable to use RhythmicStaff 928;;; without any initial pitch/drum-type. For music functions taking 929;;; pure rhythms as an argument, the running of expand-repeat-notes! 930;;; at scorification time is irrelevant: at that point of time, the 931;;; music function has already run. 932 933(define-public (expand-repeat-notes! music) 934 "Walk through @var{music} and give pitchless notes (not having a 935pitch in @code{pitch} or a drum type in @code{drum-type}) the pitch(es) 936from the predecessor note/chord if available." 937 (let ((last-pitch #f)) 938 (map-some-music 939 (lambda (m) 940 (define (set-and-ret last) 941 (set! last-pitch last) 942 m) 943 (cond 944 ((music-is-of-type? m 'event-chord) 945 (if (any (lambda (m) (music-is-of-type? m 'rhythmic-event)) 946 (ly:music-property m 'elements)) 947 (set! last-pitch m)) 948 m) 949 ((music-is-of-type? m 'note-event) 950 (cond 951 ((or (ly:music-property m 'pitch #f) 952 (ly:music-property m 'drum-type #f)) 953 => set-and-ret) 954 ;; ok, naked rhythm. Go through the various cases of 955 ;; last-pitch 956 ;; nothing available: just keep as-is 957 ((not last-pitch) m) 958 ((ly:pitch? last-pitch) 959 (set! (ly:music-property m 'pitch) last-pitch) 960 m) 961 ((symbol? last-pitch) 962 (set! (ly:music-property m 'drum-type) last-pitch) 963 m) 964 ;; Ok, this is the big bad one: the reference is a chord. 965 ;; For now, we use the repeat chord logic. That's not 966 ;; really efficient as cleaning out all articulations is 967 ;; quite simpler than what copy-repeat-chord does. 968 (else 969 (copy-repeat-chord last-pitch 970 (make-music 'EventChord 971 'elements 972 (ly:music-property m 'articulations) 973 'origin 974 (ly:music-property m 'origin)) 975 (ly:music-property m 'duration) 976 '(rhythmic-event))))) 977 (else #f))) 978 music))) 979 980;;; splitting chords into voices. 981(define (voicify-list locs lst id) 982 "Make a list of Musics. 983 984voicify-list :: [ [Music ] ] -> id -> [Music] 985LST is a list music-lists. 986 987id is 1-based, i.e., Voice=1 (upstems) has number 1. 988 989id may be a symbol or string giving a specific voice id: in this 990case, no \voiceXXX style is selected, merely the context given. 991 992locs is a list of music expressions suitable for giving 993error locations (enclosing expression for the first element, 994preceding \\\\ separator for the others) 995" 996 (define (voicify-sublist loc sublist id) 997 (cond ((string? id) 998 (context-spec-music 999 (make-simultaneous-music sublist) 1000 'Bottom id)) 1001 ((symbol? id) 1002 (voicify-sublist loc sublist (symbol->string id))) 1003 ((and (integer? id) (exact? id) (positive? id)) 1004 (context-spec-music 1005 (make-sequential-music 1006 (list (make-voice-props-set (1- id)) 1007 (make-simultaneous-music sublist))) 1008 'Bottom (number->string id))) 1009 (else 1010 (ly:music-warning loc (_ "Bad voice id: ~a") id) 1011 (context-spec-music (make-simultaneous-music sublist) 'Bottom)))) 1012 1013 (cond ((null? lst) '()) 1014 ((number? id) 1015 (cons (voicify-sublist (car locs) (car lst) id) 1016 (voicify-list (cdr locs) (cdr lst) (1+ id)))) 1017 ((pair? id) 1018 (cons (voicify-sublist (car locs) (car lst) (car id)) 1019 (voicify-list (cdr locs) (cdr lst) (cdr id)))) 1020 ((null? id) 1021 (ly:music-warning (car locs) (_ "\\voices needs more ids")) 1022 (voicify-list locs lst 1)))) 1023 1024(define (voicify-chord ch id) 1025 "Split the parts of a chord into different Voices using separator" 1026 (let ((es (ly:music-property ch 'elements))) 1027 (set! (ly:music-property ch 'elements) 1028 (voicify-list (cons ch (filter music-separator? es)) 1029 (split-list-by-separator es music-separator?) 1030 id)) 1031 ch)) 1032 1033(define*-public (voicify-music m #:optional (id 1)) 1034 "Recursively split chords that are separated with @code{\\\\}. 1035Optional @var{id} can be a list of context ids to use. If numeric, 1036they also indicate a voice type override. If @var{id} is just a single 1037number, that's where numbering starts." 1038 (let loop ((m m)) 1039 (if (not (ly:music? m)) 1040 (ly:error (_ "music expected: ~S") m)) 1041 (let ((es (ly:music-property m 'elements)) 1042 (e (ly:music-property m 'element))) 1043 1044 (if (pair? es) 1045 (set! (ly:music-property m 'elements) (map loop es))) 1046 (if (ly:music? e) 1047 (set! (ly:music-property m 'element) (loop e))) 1048 (if (and (equal? (ly:music-property m 'name) 'SimultaneousMusic) 1049 (any music-separator? es)) 1050 (context-spec-music (voicify-chord m id) 'Staff) 1051 m)))) 1052 1053(define-public (empty-music) 1054 (make-music 'Music)) 1055 1056;; Make a function that checks score element for being of a specific type. 1057(define-public (make-type-checker symbol) 1058 (lambda (elt) 1059 (grob::has-interface elt symbol))) 1060 1061(define ((outputproperty-compatibility func sym val) grob g-context ao-context) 1062 (if (func grob) 1063 (set! (ly:grob-property grob sym) val))) 1064(export outputproperty-compatibility) 1065 1066 1067(define ((set-output-property grob-name symbol val) grob grob-c context) 1068 "Usage example: 1069@code{\\applyoutput #(set-output-property 'Clef 'extra-offset '(0 . 1))}" 1070 (let ((meta (ly:grob-property grob 'meta))) 1071 (if (equal? (assoc-get 'name meta) grob-name) 1072 (set! (ly:grob-property grob symbol) val)))) 1073(export set-output-property) 1074 1075 1076(define-public (skip->rest mus) 1077 "Replace @var{mus} by @code{RestEvent} of the same duration if it is a 1078@code{SkipEvent}. Useful for extracting parts from crowded scores." 1079 1080 (if (memq (ly:music-property mus 'name) '(SkipEvent SkipMusic)) 1081 (make-music 'RestEvent 'duration (ly:music-property mus 'duration)) 1082 mus)) 1083 1084 1085(define-public (music-clone music . music-properties) 1086 "Clone @var{music} and set properties according to 1087@var{music-properties}, a list of alternating property symbols and 1088values: 1089 1090@example 1091(music-clone start-span 'span-direction STOP) 1092@end example 1093 1094Only properties that are not overridden by @var{music-properties} are 1095actually fully cloned." 1096 (let ((old-props (list-copy (ly:music-mutable-properties music))) 1097 (new-props '()) 1098 (m (ly:make-music (ly:prob-immutable-properties music)))) 1099 (define (set-props mus-props) 1100 (if (and (not (null? mus-props)) 1101 (not (null? (cdr mus-props)))) 1102 (begin 1103 (set! old-props (assq-remove! old-props (car mus-props))) 1104 (set! new-props 1105 (assq-set! new-props 1106 (car mus-props) (cadr mus-props))) 1107 (set-props (cddr mus-props))))) 1108 (set-props music-properties) 1109 (for-each 1110 (lambda (pair) 1111 (set! (ly:music-property m (car pair)) 1112 (ly:music-deep-copy (cdr pair)))) 1113 old-props) 1114 (for-each 1115 (lambda (pair) 1116 (set! (ly:music-property m (car pair)) (cdr pair))) 1117 new-props) 1118 m)) 1119 1120;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1121;; warn for bare chords at start. 1122 1123(define-public (ly:music-message music msg . rest) 1124 (let ((ip (ly:music-property music 'origin))) 1125 (if (ly:input-location? ip) 1126 (apply ly:input-message ip msg rest) 1127 (apply ly:message msg rest)))) 1128 1129(define-public (ly:music-warning music msg . rest) 1130 (let ((ip (ly:music-property music 'origin))) 1131 (if (ly:input-location? ip) 1132 (apply ly:input-warning ip msg rest) 1133 (apply ly:warning msg rest)))) 1134 1135(define-public (ly:music-error music msg . rest) 1136 (ly:parser-error (apply format #f msg rest) 1137 (ly:music-property music 'origin))) 1138 1139(define-public (ly:event-warning event msg . rest) 1140 (let ((ip (ly:event-property event 'origin))) 1141 (if (ly:input-location? ip) 1142 (apply ly:input-warning ip msg rest) 1143 (apply ly:warning msg rest)))) 1144 1145(define-public (ly:grob-warning grob path msg . rest) 1146 (let* ((name (assoc-get 'name (ly:grob-property grob 'meta))) 1147 (path-string (string-join 1148 (map symbol->string 1149 (if path 1150 ((if (list? path) cons list) name path) 1151 (list name))) 1152 ".")) 1153 (event (event-cause grob))) 1154 (if event (apply ly:event-warning event (string-append path-string ": " msg) rest) 1155 (apply ly:warning (string-append path-string ": " msg) rest)))) 1156 1157;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1158;; 1159;; setting stuff for grace context. 1160;; 1161 1162(define (vector-extend v x) 1163 "Make a new vector consisting of V, with X added to the end." 1164 (let* ((n (vector-length v)) 1165 (nv (make-vector (+ n 1) '()))) 1166 (vector-move-left! v 0 n nv 0) 1167 (vector-set! nv n x) 1168 nv)) 1169 1170(define (vector-map f v) 1171 "Map F over V. This function returns nothing." 1172 (do ((n (vector-length v)) 1173 (i 0 (+ i 1))) 1174 ((>= i n)) 1175 (f (vector-ref v i)))) 1176 1177(define (vector-reverse-map f v) 1178 "Map F over V, N to 0 order. This function returns nothing." 1179 (do ((i (- (vector-length v) 1) (- i 1))) 1180 ((< i 0)) 1181 (f (vector-ref v i)))) 1182 1183(define-public (add-grace-property context-name grob sym val) 1184 "Set @var{sym}=@var{val} for @var{grob} in @var{context-name}." 1185 (define (set-prop context) 1186 (let* ((where (or (ly:context-find context context-name) context)) 1187 (current (ly:context-property where 'graceSettings)) 1188 (new-settings (append current 1189 (list (list context-name grob sym val))))) 1190 (ly:context-set-property! where 'graceSettings new-settings))) 1191 (make-apply-context set-prop)) 1192 1193(define-public (remove-grace-property context-name grob sym) 1194 "Remove all @var{sym} for @var{grob} in @var{context-name}." 1195 (define (sym-grob-context? property sym grob context-name) 1196 (and (eq? (car property) context-name) 1197 (eq? (cadr property) grob) 1198 (eq? (caddr property) sym))) 1199 (define (delete-prop context) 1200 (let* ((where (or (ly:context-find context context-name) context)) 1201 (current (ly:context-property where 'graceSettings)) 1202 (prop-settings (filter 1203 (lambda(x) (sym-grob-context? x sym grob context-name)) 1204 current)) 1205 (new-settings current)) 1206 (for-each (lambda(x) 1207 (set! new-settings (delete x new-settings))) 1208 prop-settings) 1209 (ly:context-set-property! where 'graceSettings new-settings))) 1210 (make-apply-context delete-prop)) 1211 1212 1213(defmacro-public def-grace-function (start stop . docstring) 1214 "Helper macro for defining grace music" 1215 `(define-music-function (music) (ly:music?) 1216 ,@docstring 1217 (make-music 'GraceMusic 1218 'element (make-music 'SequentialMusic 1219 'elements (list (ly:music-deep-copy ,start) 1220 music 1221 (ly:music-deep-copy ,stop)))))) 1222 1223(defmacro-public define-syntax-function (type args signature . body) 1224 "Helper macro for `ly:make-music-function'. 1225Syntax: 1226 (define-syntax-function result-type? (arg1 arg2 ...) (arg1-type arg2-type ...) 1227 ...function body...) 1228 1229argX-type can take one of the forms @code{predicate?} for mandatory 1230arguments satisfying the predicate, @code{(predicate?)} for optional 1231parameters of that type defaulting to @code{#f}, @code{@w{(predicate? 1232value)}} for optional parameters with a specified default 1233value (evaluated at definition time). An optional parameter can be 1234omitted in a call only when it can't get confused with a following 1235parameter of different type. 1236 1237@code{result-type?} can specify a default in the same manner as 1238predicates, to be used in case of a type error in arguments or 1239result." 1240 1241 (define (has-parser/location? arg where) 1242 (let loop ((arg arg)) 1243 (if (list? arg) 1244 (any loop arg) 1245 (memq arg where)))) 1246 (define (currying-lambda args doc-string? body) 1247 (if (and (pair? args) 1248 (pair? (car args))) 1249 (currying-lambda (car args) doc-string? 1250 `((lambda ,(cdr args) ,@body))) 1251 (let* ((compatibility? (if (list? args) 1252 (= (length args) (+ 2 (length signature))) 1253 (and (pair? args) (pair? (cdr args)) 1254 (eq? (car args) 'parser)))) 1255 (realargs (if compatibility? (cddr args) args))) 1256 `(lambda ,realargs 1257 ,(format #f "~a\n~a" realargs (or doc-string? "")) 1258 ,@(if (and compatibility? 1259 (has-parser/location? body (take args 2))) 1260 `((let ((,(car args) (*parser*)) (,(cadr args) (*location*))) 1261 ,@body)) 1262 body))))) 1263 1264 (let ((docstring 1265 (and (pair? body) (pair? (cdr body)) 1266 (if (string? (car body)) 1267 (car body) 1268 (and (pair? (car body)) 1269 (eq? '_i (caar body)) 1270 (pair? (cdar body)) 1271 (string? (cadar body)) 1272 (null? (cddar body)) 1273 (cadar body)))))) 1274 ;; When the music function definition contains an i10n doc string, 1275 ;; (_i "doc string"), keep the literal string only 1276 `(ly:make-music-function 1277 (list ,@(map (lambda (pred) 1278 (if (pair? pred) 1279 `(cons ,(car pred) 1280 ,(and (pair? (cdr pred)) (cadr pred))) 1281 pred)) 1282 (cons type signature))) 1283 ,(currying-lambda args docstring (if docstring (cdr body) body))))) 1284 1285(defmacro-public define-music-function rest 1286 "Defining macro returning music functions. 1287Syntax: 1288 (define-music-function (arg1 arg2 ...) (arg1-type? arg2-type? ...) 1289 ...function body...) 1290 1291argX-type can take one of the forms @code{predicate?} for mandatory 1292arguments satisfying the predicate, @code{(predicate?)} for optional 1293parameters of that type defaulting to @code{#f}, @code{@w{(predicate? 1294value)}} for optional parameters with a specified default 1295value (evaluated at definition time). An optional parameter can be 1296omitted in a call only when it can't get confused with a following 1297parameter of different type. 1298 1299Must return a music expression. The @code{origin} is automatically 1300set to the @code{location} parameter." 1301 1302 `(define-syntax-function (ly:music? (make-music 'Music 'void #t)) ,@rest)) 1303 1304 1305(defmacro-public define-scheme-function rest 1306 "Defining macro returning Scheme functions. 1307Syntax: 1308 (define-scheme-function (arg1 arg2 ...) (arg1-type? arg2-type? ...) 1309 ...function body...) 1310 1311argX-type can take one of the forms @code{predicate?} for mandatory 1312arguments satisfying the predicate, @code{(predicate?)} for optional 1313parameters of that type defaulting to @code{#f}, @code{@w{(predicate? 1314value)}} for optional parameters with a specified default 1315value (evaluated at definition time). An optional parameter can be 1316omitted in a call only when it can't get confused with a following 1317parameter of different type. 1318 1319Can return arbitrary expressions. If a music expression is returned, 1320its @code{origin} is automatically set to the @code{location} 1321parameter." 1322 1323 `(define-syntax-function scheme? ,@rest)) 1324 1325(defmacro-public define-void-function rest 1326 "This defines a Scheme function like @code{define-scheme-function} with 1327void return value (i.e., what most Guile functions with `unspecified' 1328value return). Use this when defining functions for executing actions 1329rather than returning values, to keep Lilypond from trying to interpret 1330the return value." 1331 `(define-syntax-function (void? *unspecified*) ,@rest *unspecified*)) 1332 1333(defmacro-public define-event-function rest 1334 "Defining macro returning event functions. 1335Syntax: 1336 (define-event-function (arg1 arg2 ...) (arg1-type? arg2-type? ...) 1337 ...function body...) 1338 1339argX-type can take one of the forms @code{predicate?} for mandatory 1340arguments satisfying the predicate, @code{(predicate?)} for optional 1341parameters of that type defaulting to @code{#f}, @code{@w{(predicate? 1342value)}} for optional parameters with a specified default 1343value (evaluated at definition time). An optional parameter can be 1344omitted in a call only when it can't get confused with a following 1345parameter of different type. 1346 1347Must return an event expression. The @code{origin} is automatically 1348set to the @code{location} parameter." 1349 1350 `(define-syntax-function (ly:event? (make-music 'Event 'void #t)) ,@rest)) 1351 1352;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1353 1354;; Urgh. This documentation string is completely incomprehensible – right 1355;; now, `quote-substitute` is undocumented. 1356(define-public (cue-substitute quote-music) 1357 "Must happen after @code{quote-substitute}." 1358 1359 (if (vector? (ly:music-property quote-music 'quoted-events)) 1360 (let* ((dir (ly:music-property quote-music 'quoted-voice-direction)) 1361 (clef (ly:music-property quote-music 'quoted-music-clef #f)) 1362 (main-voice (case dir ((1) 1) ((-1) 0) (else #f))) 1363 (cue-voice (and main-voice (- 1 main-voice))) 1364 (cue-type (ly:music-property quote-music 'quoted-context-type #f)) 1365 (cue-id (ly:music-property quote-music 'quoted-context-id)) 1366 (main-music (ly:music-property quote-music 'element)) 1367 (return-value quote-music)) 1368 1369 (if main-voice 1370 (set! (ly:music-property quote-music 'element) 1371 (make-sequential-music 1372 (list 1373 (make-voice-props-override main-voice) 1374 main-music 1375 (make-voice-props-revert))))) 1376 1377 ;; if we have stem dirs, change both quoted and main music 1378 ;; to have opposite stems. 1379 1380 ;; cannot context-spec Quote-music, since context 1381 ;; for the quotes is determined in the iterator. 1382 1383 (make-sequential-music 1384 (delq! #f 1385 (list 1386 (and clef (make-cue-clef-set clef)) 1387 (and cue-type cue-voice 1388 (context-spec-music 1389 (make-voice-props-override cue-voice) 1390 cue-type cue-id)) 1391 quote-music 1392 (and cue-type cue-voice 1393 (context-spec-music 1394 (make-voice-props-revert) 1395 cue-type cue-id)) 1396 (and clef (make-cue-clef-unset)))))) 1397 quote-music)) 1398 1399(define ((quote-substitute quote-tab) music) 1400 (let* ((quoted-name (ly:music-property music 'quoted-music-name)) 1401 (quoted-vector (and (string? quoted-name) 1402 (hash-ref quote-tab quoted-name #f)))) 1403 1404 1405 (if (string? quoted-name) 1406 (if (vector? quoted-vector) 1407 (begin 1408 (set! (ly:music-property music 'quoted-events) quoted-vector) 1409 (set! (ly:music-property music 'iterator-ctor) 1410 ly:quote-iterator::constructor)) 1411 (ly:music-warning music (format #f (_ "cannot find quoted music: `~S'") quoted-name)))) 1412 music)) 1413(export quote-substitute) 1414 1415 1416;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1417;; switch it on here, so parsing and init isn't checked (too slow!) 1418;; 1419;; automatic music transformations. 1420 1421(define (music-check-error music) 1422 (define found #f) 1423 (define (signal m) 1424 (if (and (ly:music? m) 1425 (eq? (ly:music-property m 'error-found) #t)) 1426 (set! found #t))) 1427 1428 (for-each signal (ly:music-property music 'elements)) 1429 (signal (ly:music-property music 'element)) 1430 1431 (if found 1432 (set! (ly:music-property music 'error-found) #t)) 1433 music) 1434 1435(define (precompute-music-length music) 1436 (set! (ly:music-property music 'length) 1437 (ly:music-length music)) 1438 music) 1439 1440(define (recompute-music-length music) 1441 ;; If the length property is set to a value inconsistent with the 1442 ;; length callback, correct it. In other words, avoid setting the 1443 ;; length property when it doesn't need to be set. 1444 (let ((length-callback (ly:music-property music 'length-callback))) 1445 (if (procedure? length-callback) 1446 (let ((current-length (ly:music-property music 'length))) 1447 (if (ly:moment? current-length) 1448 (let ((new-length (length-callback music))) 1449 (if (not (eq? current-length new-length)) 1450 (set! (ly:music-property music 'length) new-length))))))) 1451 music) 1452 1453(define-public (make-duration-of-length moment) 1454 "Make duration of the given @code{moment} length." 1455 (ly:make-duration 0 0 1456 (ly:moment-main-numerator moment) 1457 (ly:moment-main-denominator moment))) 1458 1459(define (make-skipped moment bool) 1460 "Depending on BOOL, set or unset skipTypesetting, 1461then make SkipMusic of the given MOMENT length, and 1462then revert skipTypesetting." 1463 (make-sequential-music 1464 (list 1465 (context-spec-music (make-property-set 'skipTypesetting bool) 1466 'Score) 1467 (make-music 'SkipMusic 'duration 1468 (make-duration-of-length moment)) 1469 (context-spec-music (make-property-set 'skipTypesetting (not bool)) 1470 'Score)))) 1471 1472(define (skip-as-needed music) 1473 "Replace MUSIC by 1474@example 1475 << @{ \\set skipTypesetting = ##f 1476 LENGTHOF(\\showFirstLength) 1477 \\set skipTypesetting = ##t 1478 LENGTHOF(\\showLastLength) @} 1479 MUSIC >> 1480@end example 1481 if appropriate. 1482 1483 When only @code{showFirstLength} is set, 1484 the @code{length} property of the music is 1485 overridden to speed up compiling." 1486 (let* 1487 ((show-last (ly:parser-lookup 'showLastLength)) 1488 (show-first (ly:parser-lookup 'showFirstLength)) 1489 (show-last-length (and (ly:music? show-last) 1490 (ly:music-length show-last))) 1491 (show-first-length (and (ly:music? show-first) 1492 (ly:music-length show-first))) 1493 (orig-length (ly:music-length music))) 1494 1495 ;;FIXME: if using either showFirst- or showLastLength, 1496 ;; make sure that skipBars is not set. 1497 1498 (cond 1499 1500 ;; both properties may be set. 1501 ((and show-first-length show-last-length) 1502 (let 1503 ((skip-length (ly:moment-sub orig-length show-last-length))) 1504 (make-simultaneous-music 1505 (list 1506 (make-sequential-music 1507 (list 1508 (make-skipped skip-length #t) 1509 ;; let's draw a separator between the beginning and the end 1510 (context-spec-music (make-property-set 'whichBar "||") 1511 'Timing))) 1512 (make-skipped show-first-length #f) 1513 music)))) 1514 1515 ;; we may only want to print the last length 1516 (show-last-length 1517 (let 1518 ((skip-length (ly:moment-sub orig-length show-last-length))) 1519 (make-simultaneous-music 1520 (list 1521 (make-skipped skip-length #t) 1522 music)))) 1523 1524 ;; we may only want to print the beginning; in this case 1525 ;; only the first length will be processed (much faster). 1526 (show-first-length 1527 ;; the first length must not exceed the original length. 1528 (if (ly:moment<? show-first-length orig-length) 1529 (set! (ly:music-property music 'length) 1530 show-first-length)) 1531 music) 1532 1533 (else music)))) 1534 1535 1536(define-session-public toplevel-music-functions 1537 (list 1538 (lambda (music) (expand-repeat-chords! 1539 (cons 'rhythmic-event 1540 (ly:parser-lookup '$chord-repeat-events)) 1541 music)) 1542 expand-repeat-notes! 1543 voicify-music 1544 (lambda (x) (music-map music-check-error x)) 1545 (lambda (x) (music-map precompute-music-length x)) 1546 (lambda (music) 1547 (music-map (quote-substitute (ly:parser-lookup 'musicQuotes)) music)) 1548 1549 (lambda (x) (music-map cue-substitute x)) 1550 1551 skip-as-needed)) 1552 1553;;;;;;;;;; 1554;;; general purpose music functions 1555 1556(define (shift-octave pitch octave-shift) 1557 (_i "Add @var{octave-shift} to the octave of @var{pitch}.") 1558 (ly:make-pitch 1559 (+ (ly:pitch-octave pitch) octave-shift) 1560 (ly:pitch-notename pitch) 1561 (ly:pitch-alteration pitch))) 1562 1563 1564;;;;;;;;;;;;;;;;; 1565;; lyrics 1566 1567(define (apply-durations lyric-music durations) 1568 (define (apply-duration music) 1569 (if (and (not (equal? (ly:music-length music) ZERO-MOMENT)) 1570 (ly:duration? (ly:music-property music 'duration))) 1571 (begin 1572 (set! (ly:music-property music 'duration) (car durations)) 1573 (set! durations (cdr durations))))) 1574 1575 (music-map apply-duration lyric-music)) 1576 1577 1578;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1579;; accidentals 1580 1581(define (recent-enough? bar-number alteration-def laziness) 1582 (or (number? alteration-def) 1583 (equal? laziness #t) 1584 (<= bar-number (+ (cadr alteration-def) laziness)))) 1585 1586(define (accidental-invalid? alteration-def) 1587 "Checks an alteration entry for being invalid. 1588 1589Non-key alterations are invalidated when tying into the next bar or 1590when there is a clef change, since neither repetition nor cancellation 1591can be omitted when the same note occurs again. 1592 1593Returns @code{#f} or the reason for the invalidation, a symbol." 1594 (let* ((def (if (pair? alteration-def) 1595 (car alteration-def) 1596 alteration-def))) 1597 (and (symbol? def) def))) 1598 1599(define (extract-alteration alteration-def) 1600 (cond ((number? alteration-def) 1601 alteration-def) 1602 ((pair? alteration-def) 1603 (car alteration-def)) 1604 (else 0))) 1605 1606(define (check-pitch-against-signature context pitch barnum laziness octaveness all-naturals) 1607 "Checks the need for an accidental and a @q{restore} accidental against 1608@code{localAlterations} and @code{keyAlterations}. 1609The @var{laziness} is the number of measures 1610for which reminder accidentals are used (i.e., if @var{laziness} is zero, 1611only cancel accidentals in the same measure; if @var{laziness} is three, 1612we cancel accidentals up to three measures after they first appear. 1613@var{octaveness} is either @code{'same-octave} or @code{'any-octave} and 1614specifies whether accidentals should be canceled in different octaves. 1615If @var{all-naturals} is ##t, notes that do not occur in @code{keyAlterations} 1616also get an accidental." 1617 (let* ((ignore-octave (cond ((equal? octaveness 'any-octave) #t) 1618 ((equal? octaveness 'same-octave) #f) 1619 (else 1620 (ly:warning (_ "Unknown octaveness type: ~S ") octaveness) 1621 (ly:warning (_ "Defaulting to 'any-octave.")) 1622 #t))) 1623 (key (ly:context-property context 'keyAlterations)) 1624 (local (ly:context-property context 'localAlterations)) 1625 (notename (ly:pitch-notename pitch)) 1626 (octave (ly:pitch-octave pitch)) 1627 (pitch-handle (cons octave notename)) 1628 (need-restore #f) 1629 (need-accidental #f) 1630 (previous-alteration #f) 1631 (from-other-octaves #f) 1632 (from-same-octave (assoc-get pitch-handle local)) 1633 (from-key-sig (or (assoc-get notename local) 1634 1635 ;; If no notename match is found from localAlterations, we may have a custom 1636 ;; type with octave-specific entries of the form ((octave . pitch) alteration) 1637 ;; instead of (pitch . alteration). Since this type cannot coexist with entries in 1638 ;; localAlterations, try extracting from keyAlterations instead. 1639 (assoc-get pitch-handle key)))) 1640 1641 ;; loop through localAlterations to search for a notename match from other octaves 1642 (let loop ((l local)) 1643 (if (pair? l) 1644 (let ((entry (car l))) 1645 (if (and (pair? (car entry)) 1646 (= (cdar entry) notename)) 1647 (set! from-other-octaves (cdr entry)) 1648 (loop (cdr l)))))) 1649 1650 ;; find previous alteration-def for comparison with pitch 1651 (cond 1652 ;; from same octave? 1653 ((and (not ignore-octave) 1654 from-same-octave 1655 (recent-enough? barnum from-same-octave laziness)) 1656 (set! previous-alteration from-same-octave)) 1657 1658 ;; from any octave? 1659 ((and ignore-octave 1660 from-other-octaves 1661 (recent-enough? barnum from-other-octaves laziness)) 1662 (set! previous-alteration from-other-octaves)) 1663 1664 ;; not recent enough, extract from key signature/local key signature 1665 (from-key-sig 1666 (set! previous-alteration from-key-sig))) 1667 1668 (if (accidental-invalid? previous-alteration) 1669 (set! need-accidental #t) 1670 1671 (let* ((prev-alt (extract-alteration previous-alteration)) 1672 (this-alt (ly:pitch-alteration pitch))) 1673 1674 (if (or (and all-naturals (eq? #f previous-alteration)) (not (= this-alt prev-alt))) 1675 (begin 1676 (set! need-accidental #t) 1677 (if (and (not (= this-alt 0)) 1678 (and (< (abs this-alt) (abs prev-alt)) 1679 (> (* prev-alt this-alt) 0))) 1680 (set! need-restore #t)))))) 1681 1682 (cons need-restore need-accidental))) 1683 1684(define ((make-accidental-rule octaveness laziness) context pitch barnum) 1685 "Create an accidental rule that makes its decision based on the octave of 1686the note and a laziness value. 1687 1688@var{octaveness} is either @code{'same-octave} or @code{'any-octave} and 1689defines whether the rule should respond to accidental changes in other 1690octaves than the current. @code{'same-octave} is the normal way to typeset 1691accidentals -- an accidental is made if the alteration is different from the 1692last active pitch in the same octave. @code{'any-octave} looks at the last 1693active pitch in any octave. 1694 1695@var{laziness} states over how many bars an accidental should be remembered. 1696@code{0}@tie{}is the default -- accidental lasts over 0@tie{}bar lines, that 1697is, to the end of current measure. A positive integer means that the 1698accidental lasts over that many bar lines. @w{@code{-1}} is `forget 1699immediately', that is, only look at key signature. @code{#t} is `forever'." 1700 1701 (check-pitch-against-signature context pitch barnum laziness octaveness #f)) 1702(export make-accidental-rule) 1703 1704(define ((make-accidental-dodecaphonic-rule octaveness laziness) context pitch barnum) 1705 "Variation on function make-accidental-rule that creates an dodecaphonic 1706accidental rule." 1707 1708 (check-pitch-against-signature context pitch barnum laziness octaveness #t)) 1709(export make-accidental-dodecaphonic-rule) 1710 1711(define (key-entry-notename entry) 1712 "Return the pitch of an @var{entry} in @code{localAlterations}. 1713The @samp{car} of the entry is either of the form @code{notename} or 1714of the form @code{(octave . notename)}. The latter form is used for special 1715key signatures or to indicate an explicit accidental. 1716 1717The @samp{cdr} of the entry is either a rational @code{alter} indicating 1718a key signature alteration, or of the form 1719@code{(alter . (barnum . end-mom))} indicating an alteration caused by 1720an accidental in music." 1721 (if (pair? (car entry)) 1722 (cdar entry) 1723 (car entry))) 1724 1725(define (key-entry-octave entry) 1726 "Return the octave of an entry in @code{localAlterations} 1727or @code{#f} if the entry does not have an octave. 1728See @code{key-entry-notename} for details." 1729 (and (pair? (car entry)) (caar entry))) 1730 1731(define (key-entry-bar-number entry) 1732 "Return the bar number of an entry in @code{localAlterations} 1733or @code{#f} if the entry does not have a bar number. 1734See @code{key-entry-notename} for details." 1735 (and (pair? (cdr entry)) (caddr entry))) 1736 1737(define (key-entry-end-mom entry) 1738 "Return the end moment of an entry in @code{localAlterations} 1739or @code{#f} if the entry does not have an end moment. 1740See @code{key-entry-notename} for details." 1741 (and (pair? (cdr entry)) (cdddr entry))) 1742 1743(define (key-entry-alteration entry) 1744 "Return the alteration of an entry in localAlterations 1745 1746For convenience, returns @code{0} if entry is @code{#f}." 1747 (if entry 1748 (if (number? (cdr entry)) 1749 (cdr entry) 1750 (cadr entry)) 1751 0)) 1752 1753(define-public (find-pitch-entry keysig pitch accept-global accept-local) 1754 "Return the first entry in @var{keysig} that matches @var{pitch} 1755by notename and octave. Alteration is not considered. 1756@var{accept-global} states whether key signature entries should be included. 1757@var{accept-local} states whether local accidentals should be included. 1758If no matching entry is found, @code{#f} is returned." 1759 (and (pair? keysig) 1760 (let* ((entry (car keysig)) 1761 (entryoct (key-entry-octave entry)) 1762 (entrynn (key-entry-notename entry)) 1763 (nn (ly:pitch-notename pitch))) 1764 (if (and (equal? nn entrynn) 1765 (or (not entryoct) 1766 (= entryoct (ly:pitch-octave pitch))) 1767 (if (key-entry-bar-number entry) 1768 accept-local 1769 accept-global)) 1770 entry 1771 (find-pitch-entry (cdr keysig) pitch accept-global accept-local))))) 1772 1773(define-public (neo-modern-accidental-rule context pitch barnum) 1774 "An accidental rule that typesets an accidental if it differs from the 1775key signature @emph{and} does not directly follow a note on the same 1776staff line. This rule should not be used alone because it does neither 1777look at bar lines nor different accidentals at the same note name." 1778 (let* ((keysig (ly:context-property context 'localAlterations)) 1779 (entry (find-pitch-entry keysig pitch #t #t))) 1780 (if (not entry) 1781 (cons #f #f) 1782 (let* ((global-entry (find-pitch-entry keysig pitch #t #f)) 1783 (key-acc (key-entry-alteration global-entry)) 1784 (acc (ly:pitch-alteration pitch)) 1785 (entry-end-mom (key-entry-end-mom entry)) 1786 (entry-bn (key-entry-bar-number entry)) 1787 (now (ly:context-current-moment context))) 1788 (cons #f (not (or (equal? acc key-acc) 1789 (and (equal? entry-bn barnum) 1790 (equal? entry-end-mom now))))))))) 1791 1792(define-public (dodecaphonic-no-repeat-rule context pitch barnum) 1793 "An accidental rule that typesets an accidental before every 1794note (just as in the dodecaphonic accidental style) @emph{except} if 1795the note is immediately preceded by a note with the same pitch. This 1796is a common accidental style in contemporary notation." 1797 (let* ((keysig (ly:context-property context 'localAlterations)) 1798 (entry (find-pitch-entry keysig pitch #f #t))) 1799 (if (not entry) 1800 (cons #f #t) 1801 (let ((entry-end-mom (key-entry-end-mom entry)) 1802 (entry-bn (key-entry-bar-number entry)) 1803 (entry-alt (key-entry-alteration entry)) 1804 (alt (ly:pitch-alteration pitch)) 1805 (now (ly:context-current-moment context))) 1806 (cons #t ; FIXME: why is this different from dodecaphonic? --JeanAS 1807 (not (and (equal? entry-bn barnum) 1808 (or (equal? now entry-end-mom) 1809 (ly:moment<? now entry-end-mom)) 1810 (equal? entry-alt alt)))))))) 1811 1812(define-public (teaching-accidental-rule context pitch barnum) 1813 "An accidental rule that typesets a cautionary accidental if it is 1814included in the key signature @emph{and} does not directly follow a note 1815on the same staff line." 1816 (let* ((keysig (ly:context-property context 'localAlterations)) 1817 (entry (find-pitch-entry keysig pitch #t #t)) 1818 (now (ly:context-current-moment context))) 1819 (if (not entry) 1820 (cons #f #f) 1821 (let* ((global-entry (find-pitch-entry keysig pitch #f #f)) 1822 (key-acc (key-entry-alteration global-entry)) 1823 (acc (ly:pitch-alteration pitch)) 1824 (entry-end-mom (key-entry-end-mom entry)) 1825 (entry-bn (key-entry-bar-number entry)) 1826 (now (ly:context-current-moment context))) 1827 (cons #f (not (or (equal? acc key-acc) 1828 (and (equal? entry-bn barnum) 1829 (equal? entry-end-mom now))))))))) 1830 1831(define-session-public accidental-styles 1832 ;; An alist containing specification for all accidental styles. 1833 ;; Each accidental style needs three entries for the context properties 1834 ;; extraNatural, autoAccidentals and autoCautionaries. 1835 ;; An optional fourth entry may specify a default context for the accidental 1836 ;; style, for use with the piano styles. 1837 `( 1838 ;; accidentals as they were common in the 18th century. 1839 (default #t 1840 (Staff ,(make-accidental-rule 'same-octave 0)) 1841 ()) 1842 ;; accidentals from one voice do NOT get canceled in other voices 1843 (voice #t 1844 (Voice ,(make-accidental-rule 'same-octave 0)) 1845 ()) 1846 ;; accidentals as suggested by Kurt Stone in 1847 ;; ‘Music Notation in the 20th century’. 1848 ;; This includes all the default accidentals, but accidentals also need 1849 ;; canceling in other octaves and in the next measure. 1850 (modern #f 1851 (Staff ,(make-accidental-rule 'same-octave 0) 1852 ,(make-accidental-rule 'any-octave 0) 1853 ,(make-accidental-rule 'same-octave 1)) 1854 ()) 1855 ;; the accidentals that Stone adds to the old standard as cautionaries 1856 (modern-cautionary #f 1857 (Staff ,(make-accidental-rule 'same-octave 0)) 1858 (Staff ,(make-accidental-rule 'any-octave 0) 1859 ,(make-accidental-rule 'same-octave 1))) 1860 ;; same as modern, but accidentals different from the key signature are 1861 ;; always typeset - unless they directly follow a note of the same pitch. 1862 (neo-modern #f 1863 (Staff ,(make-accidental-rule 'same-octave 0) 1864 ,(make-accidental-rule 'any-octave 0) 1865 ,(make-accidental-rule 'same-octave 1) 1866 ,neo-modern-accidental-rule) 1867 ()) 1868 (neo-modern-cautionary #f 1869 (Staff ,(make-accidental-rule 'same-octave 0)) 1870 (Staff ,(make-accidental-rule 'any-octave 0) 1871 ,(make-accidental-rule 'same-octave 1) 1872 ,neo-modern-accidental-rule)) 1873 (neo-modern-voice #f 1874 (Voice ,(make-accidental-rule 'same-octave 0) 1875 ,(make-accidental-rule 'any-octave 0) 1876 ,(make-accidental-rule 'same-octave 1) 1877 ,neo-modern-accidental-rule 1878 Staff 1879 ,(make-accidental-rule 'same-octave 0) 1880 ,(make-accidental-rule 'any-octave 0) 1881 ,(make-accidental-rule 'same-octave 1) 1882 ,neo-modern-accidental-rule) 1883 ()) 1884 (neo-modern-voice-cautionary #f 1885 (Voice ,(make-accidental-rule 'same-octave 0)) 1886 (Voice ,(make-accidental-rule 'any-octave 0) 1887 ,(make-accidental-rule 'same-octave 1) 1888 ,neo-modern-accidental-rule 1889 Staff 1890 ,(make-accidental-rule 'same-octave 0) 1891 ,(make-accidental-rule 'any-octave 0) 1892 ,(make-accidental-rule 'same-octave 1) 1893 ,neo-modern-accidental-rule)) 1894 1895 ;; Accidentals as they were common in dodecaphonic music with no tonality. 1896 ;; Each note gets one accidental. 1897 (dodecaphonic #f 1898 (Staff ,(lambda (c p bn) '(#f . #t))) 1899 ()) 1900 ;; As in dodecaphonic style with the exception that immediately 1901 ;; repeated notes (in the same voice) don't get an accidental 1902 (dodecaphonic-no-repeat #f 1903 (Staff ,dodecaphonic-no-repeat-rule) 1904 ()) 1905 ;; Variety of the dodecaphonic style. Each note gets an accidental, 1906 ;; except notes that were already handled in the same measure. 1907 (dodecaphonic-first #f 1908 (Staff ,(make-accidental-dodecaphonic-rule 'same-octave 0)) 1909 ()) 1910 1911 ;; Multivoice accidentals to be read both by musicians playing one voice 1912 ;; and musicians playing all voices. Accidentals are typeset for each 1913 ;; voice, but they ARE canceled across voices. 1914 (modern-voice #f 1915 (Voice ,(make-accidental-rule 'same-octave 0) 1916 ,(make-accidental-rule 'any-octave 0) 1917 ,(make-accidental-rule 'same-octave 1) 1918 Staff 1919 ,(make-accidental-rule 'same-octave 0) 1920 ,(make-accidental-rule 'any-octave 0) 1921 ,(make-accidental-rule 'same-octave 1)) 1922 ()) 1923 ;; same as modernVoiceAccidental except that all special accidentals 1924 ;; are typeset as cautionaries 1925 (modern-voice-cautionary #f 1926 (Voice ,(make-accidental-rule 'same-octave 0)) 1927 (Voice ,(make-accidental-rule 'any-octave 0) 1928 ,(make-accidental-rule 'same-octave 1) 1929 Staff 1930 ,(make-accidental-rule 'same-octave 0) 1931 ,(make-accidental-rule 'any-octave 0) 1932 ,(make-accidental-rule 'same-octave 1))) 1933 1934 ;; Stone's suggestions for accidentals on grand staff. 1935 ;; Accidentals are canceled across the staves 1936 ;; in the same grand staff as well 1937 (piano #f 1938 (Staff ,(make-accidental-rule 'same-octave 0) 1939 ,(make-accidental-rule 'any-octave 0) 1940 ,(make-accidental-rule 'same-octave 1) 1941 GrandStaff 1942 ,(make-accidental-rule 'any-octave 0) 1943 ,(make-accidental-rule 'same-octave 1)) 1944 () 1945 GrandStaff) 1946 (piano-cautionary #f 1947 (Staff ,(make-accidental-rule 'same-octave 0)) 1948 (Staff ,(make-accidental-rule 'any-octave 0) 1949 ,(make-accidental-rule 'same-octave 1) 1950 GrandStaff 1951 ,(make-accidental-rule 'any-octave 0) 1952 ,(make-accidental-rule 'same-octave 1)) 1953 GrandStaff) 1954 1955 ;; Accidentals on a choir staff for simultaneous reading of the 1956 ;; own voice and the surrounding choir. Similar to piano, except 1957 ;; that the first alteration within a voice is always printed. 1958 (choral #f 1959 (Voice ,(make-accidental-rule 'same-octave 0) 1960 Staff 1961 ,(make-accidental-rule 'same-octave 1) 1962 ,(make-accidental-rule 'any-octave 0) 1963 ,(make-accidental-rule 'same-octave 1) 1964 ChoirStaff 1965 ,(make-accidental-rule 'any-octave 0) 1966 ,(make-accidental-rule 'same-octave 1)) 1967 () 1968 ChoirStaff) 1969 (choral-cautionary #f 1970 (Voice ,(make-accidental-rule 'same-octave 0) 1971 Staff 1972 ,(make-accidental-rule 'same-octave 0)) 1973 (Staff ,(make-accidental-rule 'any-octave 0) 1974 ,(make-accidental-rule 'same-octave 1) 1975 ChoirStaff 1976 ,(make-accidental-rule 'any-octave 0) 1977 ,(make-accidental-rule 'same-octave 1)) 1978 ChoirStaff) 1979 1980 ;; same as modern, but cautionary accidentals are printed for all 1981 ;; non-natural tones specified by the key signature. 1982 (teaching #f 1983 (Staff ,(make-accidental-rule 'same-octave 0)) 1984 (Staff ,(make-accidental-rule 'same-octave 1) 1985 ,teaching-accidental-rule)) 1986 1987 ;; do not set localAlterations when a note alterated differently from 1988 ;; localAlterations is found. 1989 ;; Causes accidentals to be printed at every note instead of 1990 ;; remembered for the duration of a measure. 1991 ;; accidentals not being remembered, causing accidentals always to 1992 ;; be typeset relative to the time signature 1993 (forget () 1994 (Staff ,(make-accidental-rule 'same-octave -1)) 1995 ()) 1996 ;; Do not reset the key at the start of a measure. Accidentals will be 1997 ;; printed only once and are in effect until overridden, possibly many 1998 ;; measures later. 1999 (no-reset () 2000 (Staff ,(make-accidental-rule 'same-octave #t)) 2001 ()) 2002 )) 2003 2004(define-public (set-accidental-style style . rest) 2005 "Set accidental style to @var{style}. Optionally take a context 2006argument, e.g., @code{'Staff} or @code{'Voice}. The context defaults 2007to @code{Staff}, except for piano styles, which use @code{GrandStaff} 2008as a context." 2009 (let ((spec (assoc-get style accidental-styles))) 2010 (if spec 2011 (let ((extra-natural (first spec)) 2012 (auto-accs (second spec)) 2013 (auto-cauts (third spec)) 2014 (context (cond ((pair? rest) (car rest)) 2015 ((= 4 (length spec)) (fourth spec)) 2016 (else 'Staff)))) 2017 (context-spec-music 2018 (make-sequential-music 2019 (append (if (boolean? extra-natural) 2020 (list (make-property-set 'extraNatural extra-natural)) 2021 '()) 2022 (list (make-property-set 'autoAccidentals auto-accs) 2023 (make-property-set 'autoCautionaries auto-cauts)))) 2024 context)) 2025 (begin 2026 (ly:warning (_ "unknown accidental style: ~S") style) 2027 (make-sequential-music '()))))) 2028 2029(define-public (invalidate-alterations context) 2030 "Invalidate alterations in @var{context}. 2031 2032Elements of @code{'localAlterations} corresponding to local 2033alterations of the key signature have the form 2034@code{'((octave . notename) . (alter barnum . end-mom))}. 2035Replace them with a version where @code{alter} is set to @code{'clef} 2036to force a repetition of accidentals. 2037 2038Entries that conform with the current key signature are not invalidated." 2039 (let* ((keysig (ly:context-property context 'keyAlterations))) 2040 (set! (ly:context-property context 'localAlterations) 2041 (map-in-order 2042 (lambda (entry) 2043 (let* ((localalt (key-entry-alteration entry))) 2044 (if (or (accidental-invalid? localalt) 2045 (not (key-entry-bar-number entry)) 2046 (= localalt 2047 (key-entry-alteration 2048 (find-pitch-entry 2049 keysig 2050 (ly:make-pitch (key-entry-octave entry) 2051 (key-entry-notename entry) 2052 0) 2053 #t #t)))) 2054 entry 2055 (cons (car entry) (cons 'clef (cddr entry)))))) 2056 (ly:context-property context 'localAlterations))))) 2057 2058;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2059 2060(define-public (ly:music-compress mus scale) 2061 "Compress @var{mus} by @var{scale}." 2062 (let ((factor (scale->factor scale))) 2063 ;; compress the 'duration property of all elements recursively 2064 (for-some-music 2065 (lambda (m) 2066 (let ((d (ly:music-property m 'duration))) 2067 (if (ly:duration? d) 2068 (set! (ly:music-property m 'duration) 2069 (ly:duration-compress d factor))) 2070 #f)) 2071 mus) 2072 mus)) 2073 2074(define-public (skip-of-length mus) 2075 "Create a skip of exactly the same length as @var{mus}." 2076 (let* ((skip 2077 (make-music 2078 'SkipEvent 2079 'duration (ly:make-duration 0 0)))) 2080 2081 (make-event-chord (list (ly:music-compress skip (ly:music-length mus)))))) 2082 2083(define-public (skip-of-moment-span start-moment end-moment) 2084 "Make skip music fitting between @var{start-moment} and 2085@var{end-moment}. The grace part of @var{end-moment} matters only if 2086@var{start-moment} and @var{end-mom} have the same main part." 2087 (let ((delta-moment (ly:moment-sub end-moment start-moment))) 2088 (if (zero? (ly:moment-main delta-moment)) 2089 ;; start and end have same main part 2090 (if (zero? (ly:moment-grace delta-moment)) 2091 ;; neither main time nor grace time 2092 (make-skip-music ZERO-DURATION) 2093 ;; grace time only 2094 (make-grace-music 2095 (make-skip-music 2096 (ly:make-duration 0 0 (ly:moment-grace delta-moment))))) 2097 ;; start and end have different main parts 2098 (if (zero? (ly:moment-grace start-moment)) 2099 ;; main time only 2100 (make-skip-music (make-duration-of-length delta-moment)) 2101 ;; grace time and main time 2102 (make-sequential-music 2103 (list 2104 (make-grace-music 2105 (make-skip-music 2106 (ly:make-duration 0 0 (- (ly:moment-grace start-moment))))) 2107 (make-skip-music 2108 (ly:make-duration 0 0 (ly:moment-main delta-moment))))))))) 2109 2110(define-public (mmrest-of-length mus) 2111 "Create a multi-measure rest of exactly the same length as @var{mus}." 2112 2113 (let* ((skip 2114 (make-multi-measure-rest 2115 (ly:make-duration 0 0) '()))) 2116 (ly:music-compress skip (ly:music-length mus)) 2117 skip)) 2118 2119(define-public (pitch-of-note event-chord) 2120 (let ((evs (filter (lambda (x) 2121 (music-is-of-type? x 'note-event)) 2122 (ly:music-property event-chord 'elements)))) 2123 2124 (and (pair? evs) 2125 (ly:music-property (car evs) 'pitch)))) 2126 2127(define-public (duration-of-note event-chord) 2128 (cond 2129 ((pair? event-chord) 2130 (or (duration-of-note (car event-chord)) 2131 (duration-of-note (cdr event-chord)))) 2132 ((ly:music? event-chord) 2133 (let ((dur (ly:music-property event-chord 'duration))) 2134 (if (ly:duration? dur) 2135 dur 2136 (duration-of-note (ly:music-property event-chord 'elements))))) 2137 (else #f))) 2138 2139;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2140 2141(define-public (map-some-music map? music) 2142 "Walk through @var{music}, transform all elements calling @var{map?} 2143and only recurse if this returns @code{#f}. @code{elements} or 2144@code{articulations} that are not music expressions are discarded: 2145this allows some amount of filtering. 2146 2147@code{map-some-music} may overwrite the original @var{music}." 2148 (let loop ((music music)) 2149 (or (map? music) 2150 (let ((elt (ly:music-property music 'element)) 2151 (elts (ly:music-property music 'elements)) 2152 (arts (ly:music-property music 'articulations))) 2153 (if (ly:music? elt) 2154 (set! (ly:music-property music 'element) 2155 (loop elt))) 2156 (if (pair? elts) 2157 (set! (ly:music-property music 'elements) 2158 (filter! ly:music? (map! loop elts)))) 2159 (if (pair? arts) 2160 (set! (ly:music-property music 'articulations) 2161 (filter! ly:music? (map! loop arts)))) 2162 music)))) 2163 2164(define-public (for-some-music stop? music) 2165 "Walk through @var{music}, process all elements calling @var{stop?} 2166and only recurse if this returns @code{#f}." 2167 (let loop ((music music)) 2168 (if (not (stop? music)) 2169 (let ((elt (ly:music-property music 'element))) 2170 (if (ly:music? elt) 2171 (loop elt)) 2172 (for-each loop (ly:music-property music 'elements)) 2173 (for-each loop (ly:music-property music 'articulations)))))) 2174 2175(define-public (fold-some-music pred? proc init music) 2176 "This works recursively on music like @code{fold} does on a list, 2177calling @samp{(@var{pred?} music)} on every music element. If 2178@code{#f} is returned for an element, it is processed recursively 2179with the same initial value of @samp{previous}, otherwise 2180@samp{(@var{proc} music previous)} replaces @samp{previous} 2181and no recursion happens. 2182The top @var{music} is processed using @var{init} for @samp{previous}." 2183 (let loop ((music music) (previous init)) 2184 (if (pred? music) 2185 (proc music previous) 2186 (fold loop 2187 (fold loop 2188 (let ((elt (ly:music-property music 'element))) 2189 (if (null? elt) 2190 previous 2191 (loop elt previous))) 2192 (ly:music-property music 'elements)) 2193 (ly:music-property music 'articulations))))) 2194 2195(define-public (extract-music music pred?) 2196 "Return a flat list of all music matching @var{pred?} inside of 2197@var{music}, not recursing into matches themselves." 2198 (reverse! (fold-some-music pred? cons '() music))) 2199 2200(define-public (extract-named-music music music-name) 2201 "Return a flat list of all music named @var{music-name} (either a 2202single event symbol or a list of alternatives) inside of @var{music}, 2203not recursing into matches themselves." 2204 (extract-music 2205 music 2206 (if (cheap-list? music-name) 2207 (lambda (m) (memq (ly:music-property m 'name) music-name)) 2208 (lambda (m) (eq? (ly:music-property m 'name) music-name))))) 2209 2210(define-public (extract-typed-music music type) 2211 "Return a flat list of all music with @var{type} (either a single 2212type symbol or a list of alternatives) inside of @var{music}, not 2213recursing into matches themselves." 2214 (extract-music music (music-type-predicate type))) 2215 2216(define-public (event-chord-wrap! music) 2217 "Wrap isolated rhythmic events and non-postevent events in 2218@var{music} inside of an @code{EventChord}. Chord repeats @samp{q} 2219are expanded using the default settings of the parser." 2220 (map-some-music 2221 (lambda (m) 2222 (cond ((music-is-of-type? m 'event-chord) 2223 (if (pair? (ly:music-property m 'articulations)) 2224 (begin 2225 (set! (ly:music-property m 'elements) 2226 (append (ly:music-property m 'elements) 2227 (ly:music-property m 'articulations))) 2228 (set! (ly:music-property m 'articulations) '()))) 2229 m) 2230 ((music-is-of-type? m 'rhythmic-event) 2231 (let ((arts (ly:music-property m 'articulations))) 2232 (if (pair? arts) 2233 (set! (ly:music-property m 'articulations) '())) 2234 (make-event-chord (cons m arts)))) 2235 (else #f))) 2236 (expand-repeat-notes! 2237 (expand-repeat-chords! 2238 (cons 'rhythmic-event 2239 (ly:parser-lookup '$chord-repeat-events)) 2240 music)))) 2241 2242(define-public (event-chord-notes event-chord) 2243 "Return a list of all notes from @var{event-chord}." 2244 (filter 2245 (lambda (m) (eq? 'NoteEvent (ly:music-property m 'name))) 2246 (ly:music-property event-chord 'elements))) 2247 2248(define-public (event-chord-pitches event-chord) 2249 "Return a list of all pitches from @var{event-chord}." 2250 (map (lambda (x) (ly:music-property x 'pitch)) 2251 (event-chord-notes event-chord))) 2252 2253(define-public (music-pitches music) 2254 "Return a list of all pitches from @var{music}." 2255 ;; Opencoded for efficiency. 2256 (reverse! 2257 (let loop ((music music) (pitches '())) 2258 (let ((p (ly:music-property music 'pitch))) 2259 (if (ly:pitch? p) 2260 (cons p pitches) 2261 (let ((elt (ly:music-property music 'element))) 2262 (fold loop 2263 (if (ly:music? elt) 2264 (loop elt pitches) 2265 pitches) 2266 (ly:music-property music 'elements)))))))) 2267 2268(define-public (event-chord-reduce music) 2269 "Reduce event chords in @var{music} to their first note event, 2270retaining only the chord articulations. Returns the modified music." 2271 (map-some-music 2272 (lambda (m) 2273 (and (music-is-of-type? m 'event-chord) 2274 (let*-values (((notes arts) (partition 2275 (lambda (mus) 2276 (music-is-of-type? mus 'rhythmic-event)) 2277 (ly:music-property m 'elements))) 2278 ((dur) (ly:music-property m 'duration)) 2279 ((full-arts) (append arts 2280 (ly:music-property m 'articulations))) 2281 ((first-note) (and (pair? notes) (car notes)))) 2282 (cond (first-note 2283 (set! (ly:music-property first-note 'articulations) 2284 full-arts) 2285 first-note) 2286 ((ly:duration? dur) 2287 ;; A repeat chord. Produce an unpitched note. 2288 (make-music 'NoteEvent 2289 'duration dur 2290 'articulations full-arts)) 2291 (else 2292 ;; This is an empty chord. Ugh. We cannot really 2293 ;; reduce this in any manner, so we just keep it. 2294 m))))) 2295 music)) 2296 2297(defmacro-public make-relative (variables reference music) 2298 "The list of pitch or music variables in @var{variables} is used as 2299a sequence for creating relativable music from @var{music}. 2300 2301When the constructed music is used outside of @code{\\relative}, it 2302just reflects plugging in the @var{variables} into @var{music}. 2303 2304The action inside of @code{\\relative}, however, is determined by 2305first relativizing the surrogate @var{reference} with the variables 2306plugged in and then using the variables relativized as a side effect 2307of relativizing @var{reference} for evaluating @var{music}. 2308 2309Since pitches don't have the object identity required for tracing the 2310effect of the reference call, they are replaced @emph{only} for the 2311purpose of evaluating @var{reference} with simple pitched note events. 2312 2313The surrogate @var{reference} expression has to be written with that 2314in mind. In addition, it must @emph{not} contain @emph{copies} of 2315music that is supposed to be relativized but rather the 2316@emph{originals}. This @emph{includes} the pitch expressions. As a 2317rule, inside of @code{#@{@dots{}#@}} variables must @emph{only} be 2318introduced using @code{#}, never via the copying construct @code{$}. 2319The reference expression will usually just be a sequential or chord 2320expression naming all variables in sequence, implying that following 2321music will be relativized according to the resulting pitch of the last 2322or first variable, respectively. 2323 2324Since the usual purpose is to create more complex music from general 2325arguments and since music expression parts must not occur more than 2326once, one @emph{does} generally need to use copying operators in the 2327@emph{replacement} expression @var{music} when using an argument more 2328than once there. Using an argument more than once in @var{reference}, 2329in contrast, does not make sense. 2330 2331There is another fine point to mind: @var{music} must @emph{only} 2332contain freshly constructed elements or copied constructs. This will 2333be the case anyway for regular LilyPond code inside of 2334@code{#@{@dots{}#@}}, but any other elements (apart from the 2335@var{variables} themselves which are already copied) must be created 2336or copied as well. 2337 2338The reason is that it is usually permitted to change music in-place as 2339long as one does a @var{ly:music-deep-copy} on it, and such a copy of 2340the whole resulting expression will @emph{not} be able to copy 2341variables/values inside of closures where the information for 2342relativization is being stored. 2343" 2344 2345 ;; pitch and music generator might be stored instead in music 2346 ;; properties, and it might make sense to create a music type of its 2347 ;; own for this kind of construct rather than using 2348 ;; RelativeOctaveMusic 2349 (define ((make-relative::to-relative-callback variables music-call ref-call) 2350 music pitch) 2351 (let* ((ref-vars (map (lambda (v) 2352 (if (ly:pitch? v) 2353 (make-music 'NoteEvent 'pitch v) 2354 (ly:music-deep-copy v))) 2355 variables)) 2356 (after-pitch (ly:make-music-relative! (apply ref-call ref-vars) pitch)) 2357 (actual-vars (map (lambda (v r) 2358 (if (ly:pitch? v) 2359 (ly:music-property r 'pitch) 2360 r)) 2361 variables ref-vars)) 2362 (rel-music (apply music-call actual-vars))) 2363 (set! (ly:music-property music 'element) rel-music) 2364 after-pitch)) 2365 `(make-music 'RelativeOctaveMusic 2366 'to-relative-callback 2367 (,make-relative::to-relative-callback 2368 (list ,@variables) 2369 (lambda ,variables ,music) 2370 (lambda ,variables ,reference)) 2371 'element ,music)) 2372 2373;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2374;; The following functions are all associated with the crossStaff 2375;; function 2376 2377(define (close-enough? x y) 2378 "Values are close enough to ignore the difference" 2379 (< (abs (- x y)) 0.0001)) 2380 2381(define (extent-combine extents) 2382 "Combine a list of extents" 2383 (if (pair? (cdr extents)) 2384 (interval-union (car extents) (extent-combine (cdr extents))) 2385 (car extents))) 2386 2387(define ((stem-connectable? ref root) stem) 2388 "Check if the stem is connectable to the root" 2389 ;; The root is always connectable to itself 2390 (or (eq? root stem) 2391 (and 2392 ;; Horizontal positions of the stems must be almost the same 2393 (close-enough? (car (ly:grob-extent root ref X)) 2394 (car (ly:grob-extent stem ref X))) 2395 ;; The stem must be in the direction away from the root's notehead 2396 (positive? (* (ly:grob-property root 'direction) 2397 (- (car (ly:grob-extent stem ref Y)) 2398 (car (ly:grob-extent root ref Y)))))))) 2399 2400(define (stem-span-stencil span) 2401 "Connect stems if we have at least one stem connectable to the root" 2402 (let* ((system (ly:grob-system span)) 2403 (root (ly:grob-parent span X)) 2404 (stems (filter (stem-connectable? system root) 2405 (ly:grob-object span 'stems)))) 2406 (if (<= 2 (length stems)) 2407 (let* ((yextents (map (lambda (st) 2408 (ly:grob-extent st system Y)) stems)) 2409 (yextent (extent-combine yextents)) 2410 (layout (ly:grob-layout root)) 2411 (blot (ly:output-def-lookup layout 'blot-diameter))) 2412 ;; Hide spanned stems 2413 (for-each (lambda (st) 2414 (set! (ly:grob-property st 'stencil) #f)) 2415 stems) 2416 ;; Draw a nice looking stem with rounded corners 2417 (ly:round-filled-box (ly:grob-extent root root X) yextent blot)) 2418 ;; Nothing to connect, don't draw the span 2419 #f))) 2420 2421(define ((make-stem-span! stems trans) root) 2422 "Create a stem span as a child of the cross-staff stem (the root)" 2423 (let ((span (ly:engraver-make-grob trans 'Stem '()))) 2424 (ly:grob-set-parent! span X root) 2425 (set! (ly:grob-object span 'stems) stems) 2426 ;; Suppress positioning, the stem code is confused by this weird stem 2427 (set! (ly:grob-property span 'X-offset) 0) 2428 (set! (ly:grob-property span 'stencil) stem-span-stencil))) 2429 2430(define-public (cross-staff-connect stem) 2431 "Set cross-staff property of the stem to this function to connect it to 2432other stems automatically" 2433 #t) 2434 2435(define (stem-is-root? stem) 2436 "Check if automatic connecting of the stem was requested. Stems connected 2437to cross-staff beams are cross-staff, but they should not be connected to 2438other stems just because of that." 2439 (eq? cross-staff-connect (ly:grob-property-data stem 'cross-staff))) 2440 2441(define (make-stem-spans! ctx stems trans) 2442 "Create stem spans for cross-staff stems" 2443 ;; Cannot do extensive checks here, just make sure there are at least 2444 ;; two stems at this musical moment 2445 (if (<= 2 (length stems)) 2446 (let ((roots (filter stem-is-root? stems))) 2447 (for-each (make-stem-span! stems trans) roots)))) 2448 2449(define-public (Span_stem_engraver ctx) 2450 "Connect cross-staff stems to the stems above in the system." 2451 (let ((stems '())) 2452 (make-engraver 2453 ;; Record all stems for the given moment 2454 (acknowledgers 2455 ((stem-interface trans grob source) 2456 (set! stems (cons grob stems)))) 2457 ;; Process stems and reset the stem list to empty 2458 ((process-acknowledged trans) 2459 (make-stem-spans! ctx stems trans) 2460 (set! stems '()))))) 2461 2462;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2463;; The following is used by the alterBroken function. 2464 2465(define ((value-for-spanner-piece arg) grob) 2466 "Associate a piece of broken spanner @var{grob} with an element 2467of list @var{arg}." 2468 (if (ly:spanner? grob) 2469 (let* ((orig (ly:grob-original grob)) 2470 (siblings (ly:spanner-broken-into orig))) 2471 2472 (define (helper sibs arg) 2473 (if (null? arg) 2474 arg 2475 (if (eq? (car sibs) grob) 2476 (car arg) 2477 (helper (cdr sibs) (cdr arg))))) 2478 2479 (if (>= (length siblings) 2) 2480 (helper siblings arg) 2481 (car arg))) 2482 (ly:event-warning (event-cause grob) 2483 "this ~a is not a spanner" 2484 (grob::name grob)))) 2485(export value-for-spanner-piece) 2486 2487;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2488;; The following are used by the \offset function 2489 2490(define (find-value-to-offset grob prop self alist) 2491 "Return the first value of the property @var{prop} in the property 2492alist @var{alist} -- after having found @var{self}. If @var{self} is 2493not found, return the first value of @var{prop}." 2494 (let* ((lookfor (cons prop self)) 2495 (segment (member lookfor alist))) 2496 (if (not segment) 2497 (assoc-get prop alist) 2498 (if (member lookfor (cdr segment)) 2499 (begin 2500 (ly:grob-warning grob prop (_ "giving up on cloned grob transform")) 2501 (find-value-to-offset grob prop self (cdr segment))) 2502 (assoc-get prop (cdr segment)))))) 2503 2504(define (offset-multiple-types arg offsets) 2505 "Displace @var{arg} by @var{offsets} if @var{arg} is a number, a 2506number pair, or a list of number pairs. If @var{offsets} is an empty 2507list or if there is a type-mismatch, @var{arg} will be returned." 2508 (cond 2509 ((and (number? arg) (number? offsets)) 2510 (+ arg offsets)) 2511 ((and (number-pair? arg) 2512 (or (number? offsets) 2513 (number-pair? offsets))) 2514 (coord-translate arg offsets)) 2515 ((and (number-pair-list? arg) (number-pair-list? offsets)) 2516 (map coord-translate arg offsets)) 2517 (else arg))) 2518 2519(define-public (grob-transformer property func) 2520 "Create an override value good for applying @var{func} to either 2521pure or unpure values. @var{func} is called with the respective grob 2522as first argument and the default value (after resolving all callbacks) 2523as the second." 2524 (define (worker self caller grob . rest) 2525 (let* ((immutable (ly:grob-basic-properties grob)) 2526 ;; We need to search the basic-properties alist for our 2527 ;; property to obtain values to offset. Our search is 2528 ;; complicated by the fact that calling the music function 2529 ;; `offset' as an override conses a pair to the head of the 2530 ;; alist. This pair must be discounted. The closure it 2531 ;; contains is named `self' so it can be easily recognized. 2532 ;; If `offset' is called as a tweak, the basic-property 2533 ;; alist is unaffected. 2534 (target (find-value-to-offset grob property self immutable)) 2535 ;; if target is a procedure, we need to apply it to our 2536 ;; grob to calculate values to offset. 2537 (vals (apply caller target grob rest))) 2538 (func grob vals))) 2539 ;; return the container named `self'. The container self-reference 2540 ;; seems like chasing its own tail but gets dissolved by 2541 ;; define/lambda separating binding and referencing of "self". 2542 (define self (ly:make-unpure-pure-container 2543 (lambda (grob) 2544 (worker self ly:unpure-call grob)) 2545 (lambda (grob . rest) 2546 (apply worker self ly:pure-call grob rest)))) 2547 self) 2548 2549(define-public (offsetter property offsets) 2550 "Apply @var{offsets} to the default values of @var{property} of @var{grob}. 2551Offsets are restricted to immutable properties and values of type @code{number}, 2552@code{number-pair}, or @code{number-pair-list}." 2553 (define (offset-fun grob vals) 2554 (let ((can-type-be-offset? 2555 (or (number? vals) 2556 (number-pair? vals) 2557 (number-pair-list? vals)))) 2558 (if can-type-be-offset? 2559 ;; '(+inf.0 . -inf.0) would offset to itself. This will be 2560 ;; confusing to a user unaware of the default value of the 2561 ;; property, so issue a warning. 2562 (if (equal? empty-interval vals) 2563 (ly:warning (_ "default '~a of ~a is ~a and can't be offset") 2564 property grob vals) 2565 (let* ((orig (ly:grob-original grob)) 2566 (siblings 2567 (if (ly:spanner? grob) 2568 (ly:spanner-broken-into orig) 2569 '())) 2570 (total-found (length siblings)) 2571 ;; Since there is some flexibility in input 2572 ;; syntax, structure of `offsets' is normalized. 2573 (offsets 2574 (if (or (not (pair? offsets)) 2575 (number-pair? offsets) 2576 (and (number-pair-list? offsets) 2577 (number-pair-list? vals))) 2578 (list offsets) 2579 offsets))) 2580 2581 (define (helper sibs offs) 2582 ;; apply offsets to the siblings of broken spanners 2583 (if (pair? offs) 2584 (if (eq? (car sibs) grob) 2585 (offset-multiple-types vals (car offs)) 2586 (helper (cdr sibs) (cdr offs))) 2587 vals)) 2588 2589 (if (>= total-found 2) 2590 (helper siblings offsets) 2591 (offset-multiple-types vals (car offsets))))) 2592 2593 (begin 2594 (ly:warning (_ "the property '~a of ~a cannot be offset") property grob) 2595 vals)))) 2596 (grob-transformer property offset-fun)) 2597 2598;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2599;; \magnifyMusic and \magnifyStaff 2600 2601;; defined as a function instead of a list because the 2602;; all-grob-descriptions alist is not available yet 2603(define-public (find-named-props prop-name grob-descriptions) 2604 "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. If 2605@var{grob-descriptions} is equal to the @code{all-grob-descriptions} 2606alist (defined in @file{scm/define-grobs.scm}), this finds all grobs 2607that can have a value for the @var{prop-name} property, and return them 2608as a list in the following format: 2609@example 2610'((grob prop-name) 2611 (grob prop-name) 2612 ...) 2613@end example" 2614 (define (find-grobs-with-interface interface grob-descriptions) 2615 (define (has-this-interface? grob-desc) 2616 (let* ((meta (ly:assoc-get 'meta (cdr grob-desc))) 2617 (interfaces (ly:assoc-get 'interfaces meta '()))) 2618 (memq interface interfaces))) 2619 (let* ((grob-descriptions-with-this-interface 2620 (filter has-this-interface? grob-descriptions)) 2621 (grob-names-with-this-interface 2622 (map car grob-descriptions-with-this-interface))) 2623 grob-names-with-this-interface)) 2624 (let* ((interface 2625 (case prop-name 2626 ((baseline-skip word-space) 'text-interface) 2627 ((space-alist) 'break-aligned-interface) 2628 (else (ly:programming-error 2629 "find-named-props: no interface associated with ~s" 2630 prop-name)))) 2631 (grobs-with-this-prop 2632 (find-grobs-with-interface interface grob-descriptions))) 2633 (map (lambda (x) (list x prop-name)) 2634 grobs-with-this-prop))) 2635 2636 2637(define (magnifyStaff-is-set? context mag) 2638 (let* ((Staff (ly:context-find context 'Staff)) 2639 (old-mag (ly:context-property Staff 'magnifyStaffValue))) 2640 (not (null? old-mag)))) 2641 2642(define (staff-magnification-is-changing? context mag) 2643 (let* ((Staff (ly:context-find context 'Staff)) 2644 (old-mag (ly:context-property Staff 'magnifyStaffValue 1))) 2645 (not (= old-mag mag)))) 2646 2647(define-public (scale-fontSize func-name mag) 2648 "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. Look up the 2649current @code{fontSize} in the appropriate context and scale it by the 2650magnification factor @var{mag}. @var{func-name} is either 2651@code{'magnifyMusic} or @code{'magnifyStaff}." 2652 (make-apply-context 2653 (lambda (context) 2654 (if (or (eq? func-name 'magnifyMusic) 2655 ;; for \magnifyStaff, only scale the fontSize 2656 ;; if staff magnification is changing 2657 ;; and does not equal 1 2658 (and (staff-magnification-is-changing? context mag) 2659 (not (= mag 1)))) 2660 (let* ((where (case func-name 2661 ((magnifyMusic) context) 2662 ((magnifyStaff) (ly:context-find context 'Staff)))) 2663 (fontSize (ly:context-property where 'fontSize 0)) 2664 (new-fontSize (+ fontSize (magnification->font-size mag)))) 2665 (ly:context-set-property! where 'fontSize new-fontSize)))))) 2666 2667(define-public (revert-fontSize func-name mag) 2668 "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. Calculate 2669the previous @code{fontSize} value (before scaling) by factoring out the 2670magnification factor @var{mag} (if @var{func-name} is 2671@code{'magnifyMusic}), or by factoring out the context property 2672@code{magnifyStaffValue} (if @var{func-name} is @code{'magnifyStaff}). 2673Revert the @code{fontSize} in the appropriate context accordingly. 2674 2675With @code{\\magnifyMusic}, the scaling is reverted after the music 2676block it operates on. @code{\\magnifyStaff} does not operate on a music 2677block, so the scaling from a previous call (if there is one) is reverted 2678before the new scaling takes effect." 2679 (make-apply-context 2680 (lambda (context) 2681 (if (or (eq? func-name 'magnifyMusic) 2682 ;; for \magnifyStaff... 2683 (and 2684 ;; don't revert the user's fontSize choice 2685 ;; the first time \magnifyStaff is called 2686 (magnifyStaff-is-set? context mag) 2687 ;; only revert the previous fontSize 2688 ;; if staff magnification is changing 2689 (staff-magnification-is-changing? context mag))) 2690 (let* ((where 2691 (case func-name 2692 ((magnifyMusic) context) 2693 ((magnifyStaff) (ly:context-find context 'Staff)))) 2694 (old-mag 2695 (case func-name 2696 ((magnifyMusic) mag) 2697 ((magnifyStaff) 2698 (ly:context-property where 'magnifyStaffValue 1)))) 2699 (fontSize (ly:context-property where 'fontSize 0)) 2700 (old-fontSize (- fontSize (magnification->font-size old-mag)))) 2701 (ly:context-set-property! where 'fontSize old-fontSize)))))) 2702 2703(define-public (scale-props func-name mag allowed-to-shrink? props) 2704 "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. For each 2705prop in @var{props}, find the current value of the requested prop, scale 2706it by the magnification factor @var{mag}, and do the equivalent of a 2707@code{\\temporary@tie{}\\override} with the new value in the appropriate 2708context. If @var{allowed-to-shrink?} is @code{#f}, don't let the new 2709value be less than the current value. @var{func-name} is either 2710@code{'magnifyMusic} or @code{'magnifyStaff}. The @var{props} list is 2711formatted like: 2712@example 2713'((Stem thickness) 2714 (Slur line-thickness) 2715 ...) 2716@end example" 2717 (make-apply-context 2718 (lambda (context) 2719 (define (scale-prop grob-prop-list) 2720 (let* ((grob (car grob-prop-list)) 2721 (prop (cadr grob-prop-list)) 2722 (where (if (eq? grob 'SpacingSpanner) 2723 (ly:context-find context 'Score) 2724 (case func-name 2725 ((magnifyMusic) context) 2726 ((magnifyStaff) (ly:context-find context 'Staff))))) 2727 (grob-def (ly:context-grob-definition where grob))) 2728 (if (eq? prop 'space-alist) 2729 (let* ((space-alist (ly:assoc-get prop grob-def)) 2730 (scale-spacing-tuple (lambda (x) 2731 (cons (car x) 2732 (cons (cadr x) 2733 (* mag (cddr x)))))) 2734 (scaled-tuples (if space-alist 2735 (map scale-spacing-tuple space-alist) 2736 '())) 2737 (new-alist (append scaled-tuples space-alist))) 2738 (ly:context-pushpop-property where grob prop new-alist)) 2739 (let* ((val (ly:assoc-get prop grob-def (case prop 2740 ((baseline-skip) 3) 2741 ((word-space) 0.6) 2742 (else 1)))) 2743 (proc (lambda (x) 2744 (if allowed-to-shrink? 2745 (* x mag) 2746 (* x (max 1 mag))))) 2747 (new-val (if (number-pair? val) 2748 (cons (proc (car val)) 2749 (proc (cdr val))) 2750 (proc val)))) 2751 (ly:context-pushpop-property where grob prop new-val))))) 2752 (if (or (eq? func-name 'magnifyMusic) 2753 ;; for \magnifyStaff, only scale the properties 2754 ;; if staff magnification is changing 2755 ;; and does not equal 1 2756 (and (staff-magnification-is-changing? context mag) 2757 (not (= mag 1)))) 2758 (for-each scale-prop props))))) 2759 2760(define-public (revert-props func-name mag props) 2761 "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. Revert each 2762prop in @var{props} in the appropriate context. @var{func-name} is 2763either @code{'magnifyMusic} or @code{'magnifyStaff}. The @var{props} 2764list is formatted like: 2765@example 2766'((Stem thickness) 2767 (Slur line-thickness) 2768 ...) 2769@end example" 2770 (make-apply-context 2771 (lambda (context) 2772 (define (revert-prop grob-prop-list) 2773 (let* ((grob (car grob-prop-list)) 2774 (prop (cadr grob-prop-list)) 2775 (where (if (eq? grob 'SpacingSpanner) 2776 (ly:context-find context 'Score) 2777 (case func-name 2778 ((magnifyMusic) context) 2779 ((magnifyStaff) (ly:context-find context 'Staff)))))) 2780 (ly:context-pushpop-property where grob prop))) 2781 (if (or (eq? func-name 'magnifyMusic) 2782 ;; for \magnifyStaff... 2783 (and 2784 ;; don't revert the user's property overrides 2785 ;; the first time \magnifyStaff is called 2786 (magnifyStaff-is-set? context mag) 2787 ;; revert the overrides from the previous \magnifyStaff, 2788 ;; but only if staff magnification is changing 2789 (staff-magnification-is-changing? context mag))) 2790 (for-each revert-prop props))))) 2791 2792;; \magnifyMusic only 2793(define-public (scale-beam-thickness mag) 2794 "Used by @code{\\magnifyMusic}. Scaling @code{Beam.beam-thickness} 2795exactly to the @var{mag} value will not work. This uses two reference 2796values for @code{beam-thickness} to determine an acceptable value when 2797scaling, then does the equivalent of a 2798@code{\\temporary@tie{}\\override} with the new value." 2799 (make-apply-context 2800 (lambda (context) 2801 (let* ((grob-def (ly:context-grob-definition context 'Beam)) 2802 (val (ly:assoc-get 'beam-thickness grob-def 0.48)) 2803 (ratio-to-default (/ val 0.48)) 2804 ;; gives beam-thickness=0.48 when mag=1 (like default), 2805 ;; gives beam-thickness=0.35 when mag=0.63 (like CueVoice) 2806 (scaled-default (+ 119/925 (* mag 13/37))) 2807 (new-val (* scaled-default ratio-to-default))) 2808 (ly:context-pushpop-property context 'Beam 'beam-thickness new-val))))) 2809 2810;; tag management 2811;; 2812 2813(define tag-groups (make-hash-table)) 2814 2815(define-public (define-tag-group tags) 2816 "Define a tag group consisting of the given @var{tags}, a@tie{}list 2817of symbols. Returns @code{#f} if successful, and an error message if 2818there is a conflicting tag group definition." 2819 (cond ((not (symbol-list? tags)) (format #f (_ "not a symbol list: ~a") tags)) 2820 ((any (lambda (tag) (hashq-ref tag-groups tag)) tags) 2821 => (lambda (group) (and (not (lset= eq? group tags)) 2822 (format #f (_ "conflicting tag group ~a") group)))) 2823 (else 2824 (for-each 2825 (lambda (elt) (hashq-set! tag-groups elt tags)) 2826 tags) 2827 #f))) 2828 2829;; Isolate LilyPond's internal tags from the user's tags. 2830(define-tag-group '($autoChange)) 2831(define-tag-group '($partCombine)) 2832 2833;; Save the default tag groups and restore them after every session. 2834(define default-tag-groups (hash-table->alist tag-groups)) 2835(call-after-session (lambda () 2836 (set! tag-groups (alist->hash-table default-tag-groups)))) 2837 2838(define-public (tag-group-get tag) 2839 "Return the tag group (as a list of symbols) that the given 2840@var{tag} symbol belongs to, @code{#f} if none." 2841 (hashq-ref tag-groups tag)) 2842 2843(define-public (tags-remove-predicate tags) 2844 "Return a predicate that returns @code{#f} for any music that is to 2845be removed by @code{\\removeWithTag} on the given symbol or list of 2846symbols @var{tags}." 2847 (if (symbol? tags) 2848 (lambda (m) 2849 (not (memq tags (ly:music-property m 'tags)))) 2850 (lambda (m) 2851 (not (any (lambda (t) (memq t tags)) 2852 (ly:music-property m 'tags)))))) 2853 2854(define-public (tags-keep-predicate tags) 2855 "Return a predicate that returns @code{#f} for any music that is to 2856be removed by @code{\\keepWithTag} on the given symbol or list of symbols 2857@var{tags}." 2858 (if (symbol? tags) 2859 (let ((group (tag-group-get tags))) 2860 (lambda (m) 2861 (let ((music-tags (ly:music-property m 'tags))) 2862 (or 2863 (null? music-tags) ; redundant but very frequent 2864 ;; We know of only one tag to keep. Either we find it in 2865 ;; the music tags, or all music tags must be from a 2866 ;; different group 2867 (memq tags music-tags) 2868 (not (any (lambda (t) (eq? (tag-group-get t) group)) music-tags)))))) 2869 (let ((groups (delete-duplicates (map tag-group-get tags) eq?))) 2870 (lambda (m) 2871 (let ((music-tags (ly:music-property m 'tags))) 2872 (or 2873 (null? music-tags) ; redundant but very frequent 2874 (any (lambda (t) (memq t tags)) music-tags) 2875 ;; if no tag matches, no tag group should match either 2876 (not (any (lambda (t) (memq (tag-group-get t) groups)) music-tags)))))))) 2877