1;;;; This file is part of LilyPond, the GNU music typesetter. 2;;;; 3;;;; Copyright (C) 2004--2021 Han-Wen Nienhuys <hanwen@xs4all.nl> 4;;;; 5;;;; LilyPond is free software: you can redistribute it and/or modify 6;;;; it under the terms of the GNU General Public License as published by 7;;;; the Free Software Foundation, either version 3 of the License, or 8;;;; (at your option) any later version. 9;;;; 10;;;; LilyPond is distributed in the hope that it will be useful, 11;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13;;;; GNU General Public License for more details. 14;;;; 15;;;; You should have received a copy of the GNU General Public License 16;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>. 17 18;; todo: figure out how to make module, 19;; without breaking nested ly scopes 20 21(define-class <Voice-state> () 22 (event-list #:init-value '() #:accessor events #:init-keyword #:events) 23 (when-moment #:accessor moment #:init-keyword #:moment) 24 (tuning #:accessor tuning #:init-keyword #:tuning) 25 (split-index #:accessor split-index) 26 (vector-index) 27 (state-vector) 28 ;;; 29 ;; spanner-state is an alist 30 ;; of (SYMBOL . RESULT-INDEX), which indicates where 31 ;; said spanner was started. 32 (spanner-state #:init-value '() #:accessor span-state)) 33 34(define-method (write (x <Voice-state> ) file) 35 (display (moment x) file) 36 (display " evs = " file) 37 (display (events x) file) 38 (display " active = " file) 39 (display (span-state x) file) 40 (display "\n" file)) 41 42;; Return the duration of the longest event in the Voice-state. 43(define-method (duration (vs <Voice-state>)) 44 (define (duration-max event d1) 45 (let ((d2 (ly:event-property event 'duration #f))) 46 (if d2 47 (if (ly:duration<? d1 d2) d2 d1) 48 d1))) 49 50 (fold duration-max ZERO-DURATION (events vs))) 51 52(define-method (note-events (vs <Voice-state>)) 53 (define (f? x) 54 (ly:in-event-class? x 'note-event)) 55 (filter f? (events vs))) 56 57;; Return a list of note events which is sorted and stripped of 58;; properties that we do not want to prevent combining parts. 59(define-method (comparable-note-events (vs <Voice-state>)) 60 (define (note<? note1 note2) 61 (let ((p1 (ly:event-property note1 'pitch)) 62 (p2 (ly:event-property note2 'pitch))) 63 (cond ((ly:pitch<? p1 p2) #t) 64 ((ly:pitch<? p2 p1) #f) 65 (else (ly:duration<? (ly:event-property note1 'duration) 66 (ly:event-property note2 'duration)))))) 67 ;; TODO we probably should compare articulations too 68 (sort (map (lambda (x) 69 (ly:make-stream-event 70 (ly:make-event-class 'note-event) 71 (list (cons 'duration (ly:event-property x 'duration)) 72 (cons 'pitch (ly:event-property x 'pitch))))) 73 (note-events vs)) 74 note<?)) 75 76(define-method (silence-events (vs <Voice-state>)) 77 (let ((result (filter (lambda(x) 78 (or (ly:in-event-class? x 'rest-event) 79 (ly:in-event-class? x 'multi-measure-rest-event))) 80 (events vs)))) 81 ;; There may be skips in the same part with rests for various 82 ;; reasons. Regard the skips only if there are no rests. 83 (if (not (pair? result)) 84 (set! result (filter (lambda(x) (ly:in-event-class? x 'skip-event)) 85 (events vs)))) 86 result)) 87 88(define-method (any-mmrest-events (vs <Voice-state>)) 89 (define (f? x) 90 (ly:in-event-class? x 'multi-measure-rest-event)) 91 (any f? (events vs))) 92 93(define-method (previous-voice-state (vs <Voice-state>)) 94 (let ((i (slot-ref vs 'vector-index)) 95 (v (slot-ref vs 'state-vector))) 96 (if (< 0 i) 97 (vector-ref v (1- i)) 98 #f))) 99 100;; true if the part has ended 101(define-method (done? (vs <Voice-state>)) 102 (let ((i (slot-ref vs 'vector-index)) 103 (v (slot-ref vs 'state-vector))) 104 ;; the last entry represents the end of the part 105 (= (1+ i) (vector-length v)))) 106 107;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 108 109(define-class <Split-state> () 110 ;; The automatically determined split configuration 111 (configuration #:init-value '() #:accessor configuration) 112 ;; Allow overriding split configuration, takes precedence over configuration 113 (forced-configuration #:init-value #f #:accessor forced-configuration) 114 (when-moment #:accessor moment #:init-keyword #:moment) 115 ;; voice-states are states starting with the Split-state or later 116 ;; 117 (is #:init-keyword #:voice-states #:accessor voice-states) 118 (synced #:init-keyword #:synced #:init-value #f #:getter synced?)) 119 120 121(define-method (write (x <Split-state> ) f) 122 (display (moment x) f) 123 (display " = " f) 124 (display (configuration x) f) 125 (if (synced? x) 126 (display " synced ")) 127 (display "\n" f)) 128 129(define-method (current-or-previous-voice-states (ss <Split-state>)) 130 "Return voice states meeting the following conditions. For a voice 131in sync, return the current voice state. For a voice out of sync, 132return the previous voice state." 133 (let* ((vss (voice-states ss)) 134 (vs1 (car vss)) 135 (vs2 (cdr vss))) 136 (if (and vs1 (not (equal? (moment vs1) (moment ss)))) 137 (set! vs1 (previous-voice-state vs1))) 138 (if (and vs2 (not (equal? (moment vs2) (moment ss)))) 139 (set! vs2 (previous-voice-state vs2))) 140 (cons vs1 vs2))) 141 142;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 143 144 145(define (previous-span-state vs) 146 (let ((p (previous-voice-state vs))) 147 (if p (span-state p) '()))) 148 149(define (make-voice-states evl) 150 (let* ((states (map (lambda (v) 151 (make <Voice-state> 152 #:moment (caar v) 153 #:tuning (cdar v) 154 #:events (map car (cdr v)))) 155 (reverse evl)))) 156 157 ;; TODO: Add an entry at +inf.0 and see if it allows us to remove 158 ;; the many instances of conditional code handling the case that 159 ;; there is no voice state at a given moment. 160 161 (let ((vec (list->vector (reverse! states)))) 162 (do ((i 0 (1+ i))) 163 ((= i (vector-length vec)) vec) 164 (slot-set! (vector-ref vec i) 'vector-index i) 165 (slot-set! (vector-ref vec i) 'state-vector vec))))) 166 167(define (make-split-state vs1 vs2) 168 "Merge lists VS1 and VS2, containing Voice-state objects into vector 169of Split-state objects, crosslinking the Split-state vector and 170Voice-state objects 171" 172 (define (helper ss-idx ss-list idx1 idx2) 173 (let* ((state1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f)) 174 (state2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f)) 175 (min (cond ((and state1 state2) (moment-min (moment state1) (moment state2))) 176 (state1 (moment state1)) 177 (state2 (moment state2)) 178 (else #f))) 179 (inc1 (if (and state1 (equal? min (moment state1))) 1 0)) 180 (inc2 (if (and state2 (equal? min (moment state2))) 1 0)) 181 (ss-object (if min 182 (make <Split-state> 183 #:moment min 184 #:voice-states (cons state1 state2) 185 #:synced (= inc1 inc2)) 186 #f))) 187 (if state1 188 (set! (split-index state1) ss-idx)) 189 (if state2 190 (set! (split-index state2) ss-idx)) 191 (if min 192 (helper (1+ ss-idx) 193 (cons ss-object ss-list) 194 (+ idx1 inc1) 195 (+ idx2 inc2)) 196 ss-list))) 197 (list->vector (reverse! (helper 0 '() 0 0) '()))) 198 199(define (analyse-spanner-states voice-state-vec) 200 201 (define (helper index active) 202 "Analyse EVS at INDEX, given state ACTIVE." 203 204 (define (analyse-tie-start active ev) 205 (if (ly:in-event-class? ev 'tie-event) 206 (acons 'tie (split-index (vector-ref voice-state-vec index)) 207 active) 208 active)) 209 210 (define (analyse-tie-end active ev) 211 (if (ly:in-event-class? ev 'note-event) 212 (assoc-remove! active 'tie) 213 active)) 214 215 (define (analyse-absdyn-end active ev) 216 (if (or (ly:in-event-class? ev 'absolute-dynamic-event) 217 (and (ly:in-event-class? ev 'span-dynamic-event) 218 (equal? STOP (ly:event-property ev 'span-direction)))) 219 (assoc-remove! (assoc-remove! active 'cresc) 'decr) 220 active)) 221 222 (define (active<? a b) 223 (cond ((symbol<? (car a) (car b)) #t) 224 ((symbol<? (car b) (car a)) #f) 225 (else (< (cdr a) (cdr b))))) 226 227 (define (analyse-span-event active ev) 228 (let* ((name (car (ly:event-property ev 'class))) 229 (key (cond ((equal? name 'slur-event) 'slur) 230 ((equal? name 'phrasing-slur-event) 'tie) 231 ((equal? name 'beam-event) 'beam) 232 ((equal? name 'crescendo-event) 'cresc) 233 ((equal? name 'decrescendo-event) 'decr) 234 (else #f))) 235 (sp (ly:event-property ev 'span-direction))) 236 (if (and (symbol? key) (ly:dir? sp)) 237 (if (= sp STOP) 238 (assoc-remove! active key) 239 (acons key 240 (split-index (vector-ref voice-state-vec index)) 241 active)) 242 active))) 243 244 (define (analyse-events active evs) 245 "Run all analyzers on ACTIVE and EVS" 246 (define (run-analyzer analyzer active evs) 247 (if (pair? evs) 248 (run-analyzer analyzer (analyzer active (car evs)) (cdr evs)) 249 active)) 250 (define (run-analyzers analyzers active evs) 251 (if (pair? analyzers) 252 (run-analyzers (cdr analyzers) 253 (run-analyzer (car analyzers) active evs) 254 evs) 255 active)) 256 (sort ;; todo: use fold or somesuch. 257 (run-analyzers (list analyse-absdyn-end analyse-span-event 258 ;; note: tie-start/span comes after tie-end/absdyn. 259 analyse-tie-end analyse-tie-start) 260 active evs) 261 active<?)) 262 263 ;; must copy, since we use assoc-remove! 264 (if (< index (vector-length voice-state-vec)) 265 (begin 266 (set! active (analyse-events active (events (vector-ref voice-state-vec index)))) 267 (set! (span-state (vector-ref voice-state-vec index)) 268 (list-copy active)) 269 (helper (1+ index) active)))) 270 271 (helper 0 '())) 272 273(define recording-group-functions 274 ;;Selected parts from @var{toplevel-music-functions} not requiring @code{parser}. 275 (list 276 (lambda (music) (expand-repeat-chords! '(rhythmic-event) music)) 277 expand-repeat-notes!)) 278 279 280;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 281(define-public (recording-group-emulate music odef) 282 "Interpret @var{music} according to @var{odef}, but store all events 283in a chronological list, similar to the @code{Recording_group_engraver} in 284LilyPond version 2.8 and earlier." 285 (let* 286 ((context-list '()) 287 (now-mom (ly:make-moment 0 0)) 288 (global (ly:make-global-context odef)) 289 (mom-listener (lambda (tev) (set! now-mom (ly:event-property tev 'moment)))) 290 (new-context-listener 291 (lambda (sev) 292 (let* 293 ((child (ly:event-property sev 'context)) 294 (this-moment-list (cons (ly:context-id child) '())) 295 (dummy (set! context-list (cons this-moment-list context-list))) 296 (acc '()) 297 (accumulate-event-listener 298 (lambda (ev) 299 (set! acc (cons (cons ev #t) acc)))) 300 (remove-context-listener 301 (lambda (ev) 302 "Add a final entry to record the end moment." 303 (let ((this-moment (cons (cons 304 now-mom 305 #f ; instrumentTransposition 306 ) 307 '() ; events 308 ))) 309 (set-cdr! this-moment-list 310 (cons this-moment (cdr this-moment-list)))))) 311 (save-acc-listener 312 (lambda (tev) 313 (if (pair? acc) 314 (let ((this-moment 315 (cons (cons now-mom 316 (ly:context-property child 'instrumentTransposition)) 317 ;; The accumulate-event-listener above creates 318 ;; the list of events in reverse order, so we 319 ;; have to revert it to the original order again 320 (reverse acc)))) 321 (set-cdr! this-moment-list 322 (cons this-moment (cdr this-moment-list))) 323 (set! acc '())))))) 324 (ly:add-listener accumulate-event-listener 325 (ly:context-event-source child) 'StreamEvent) 326 (ly:add-listener remove-context-listener 327 (ly:context-event-source child) 'RemoveContext) 328 (ly:add-listener save-acc-listener 329 (ly:context-event-source global) 'OneTimeStep))))) 330 (ly:add-listener new-context-listener 331 (ly:context-events-below global) 'AnnounceNewContext) 332 (ly:add-listener mom-listener (ly:context-event-source global) 'Prepare) 333 (ly:interpret-music-expression 334 (make-non-relative-music 335 (fold (lambda (x m) (x m)) music recording-group-functions)) 336 global) 337 context-list)) 338 339(define-public (determine-split-list evl1 evl2 chord-range) 340 "Event lists @var{evl1} and @var{evl2} should be ascending. 341@var{chord-range} is a pair of numbers @code{(min . max)} defining the distance 342in steps between notes that may be combined into a chord or unison." 343 (let* ((pc-debug #f) 344 (voice-state-vec1 (make-voice-states evl1)) 345 (voice-state-vec2 (make-voice-states evl2)) 346 (result (make-split-state voice-state-vec1 voice-state-vec2)) 347 (chord-min-diff (car chord-range)) 348 (chord-max-diff (cdr chord-range))) 349 350 ;; Go through all moments recursively and check if the events of that 351 ;; moment contain a part-combine-force-event override. If so, store its 352 ;; value in the forced-configuration field, which will override. The 353 ;; previous configuration is used to determine non-terminated settings. 354 (define (analyse-forced-combine result-idx prev-res) 355 356 (define (get-forced-event x) 357 (cond 358 ((and (ly:in-event-class? x 'SetProperty) 359 (eq? (ly:event-property x 'symbol) 'partCombineForced)) 360 (cons (ly:event-property x 'value #f) 361 (ly:event-property x 'once #f))) 362 ((and (ly:in-event-class? x 'UnsetProperty) 363 (eq? (ly:event-property x 'symbol) 'partCombineForced)) 364 (cons #f (ly:event-property x 'once #f))) 365 (else #f))) 366 367 (define (part-combine-events vs) 368 (if (not vs) 369 '() 370 (filter-map get-forced-event (events vs)))) 371 ;; end part-combine-events 372 373 ;; forced-result: Take the previous config and analyse whether 374 ;; any change happened.... Return new once and permanent config 375 (define (forced-result evt state) 376 ;; sanity check, evt should always be (new-state . once) 377 (if (not (and (pair? evt) (pair? state))) 378 state 379 (if (cdr evt) 380 ;; Once-event, leave permanent state unchanged 381 (cons (car evt) (cdr state)) 382 ;; permanent change, leave once state unchanged 383 (cons (car state) (car evt))))) 384 ;; end forced-combine-result 385 386 ;; body of analyse-forced-combine: 387 (if (< result-idx (vector-length result)) 388 (let* ((now-state (vector-ref result result-idx)) ; current result 389 ;; Extract all part-combine force events 390 (evts (if (synced? now-state) 391 (append 392 (part-combine-events (car (voice-states now-state))) 393 (part-combine-events (cdr (voice-states now-state)))) 394 '())) 395 ;; result is (once-state permament-state): 396 (state (fold forced-result (cons 'automatic prev-res) evts)) 397 ;; Now let once override permanent changes: 398 (force-state (if (equal? (car state) 'automatic) 399 (cdr state) 400 (car state)))) 401 (set! (forced-configuration (vector-ref result result-idx)) 402 force-state) 403 ;; For the next moment, ignore the once override (car stat) 404 ;; and pass on the permanent override, stored as (cdr state) 405 (analyse-forced-combine (1+ result-idx) (cdr state))))) 406 ;; end analyse-forced-combine 407 408 409 (define (analyse-time-step result-idx) 410 (define (put x . index) 411 "Put the result to X, starting from INDEX backwards. 412 413Only set if not set previously. 414" 415 (let ((i (if (pair? index) (car index) result-idx))) 416 (if (and (<= 0 i) 417 (not (symbol? (configuration (vector-ref result i))))) 418 (begin 419 (set! (configuration (vector-ref result i)) x) 420 (put x (1- i)))))) 421 422 (define (copy-state-from state-vec vs) 423 (define (copy-one-state key-idx) 424 (let* ((idx (cdr key-idx)) 425 (prev-ss (vector-ref result idx)) 426 (prev (configuration prev-ss))) 427 (if (symbol? prev) 428 (put prev)))) 429 (for-each copy-one-state (span-state vs))) 430 431 (define (analyse-notes now-state) 432 (let* ((vs1 (car (voice-states now-state))) 433 (vs2 (cdr (voice-states now-state))) 434 (notes1 (comparable-note-events vs1)) 435 (notes2 (comparable-note-events vs2))) 436 (cond 437 ;; if neither part has notes, do nothing 438 ((and (not (pair? notes1)) (not (pair? notes2)))) 439 440 ;; if one part has notes and the other does not 441 ((or (not (pair? notes1)) (not (pair? notes2))) (put 'apart)) 442 443 ;; if either part has a chord 444 ((or (> (length notes1) 1) 445 (> (length notes2) 1)) 446 (if (and (<= chord-min-diff 0) ; user requests combined unisons 447 (equal? notes1 notes2)) ; both parts have the same chord 448 (put 'chords) 449 (put 'apart))) 450 451 ;; if the durations are different 452 ;; TODO articulations too? 453 ((and (not (equal? (ly:event-property (car notes1) 'duration) 454 (ly:event-property (car notes2) 'duration)))) 455 (put 'apart)) 456 457 (else 458 ;; Is the interval outside of chord-range? 459 (if (let ((diff (ly:pitch-steps 460 (ly:pitch-diff 461 (ly:event-property (car notes1) 'pitch) 462 (ly:event-property (car notes2) 'pitch))))) 463 (or (< diff chord-min-diff) 464 (> diff chord-max-diff) 465 )) 466 (put 'apart) 467 ;; copy previous split state from spanner state 468 (begin 469 (if (previous-voice-state vs1) 470 (copy-state-from voice-state-vec1 471 (previous-voice-state vs1))) 472 (if (previous-voice-state vs2) 473 (copy-state-from voice-state-vec2 474 (previous-voice-state vs2))) 475 (if (and (null? (span-state vs1)) (null? (span-state vs2))) 476 (put 'chords)))))))) 477 478 (if (< result-idx (vector-length result)) 479 (let* ((now-state (vector-ref result result-idx)) 480 (vs1 (car (voice-states now-state))) 481 (vs2 (cdr (voice-states now-state)))) 482 483 (cond ((not vs1) (put 'apart)) 484 ((not vs2) (put 'apart)) 485 (else 486 (let ((active1 (previous-span-state vs1)) 487 (active2 (previous-span-state vs2)) 488 (new-active1 (span-state vs1)) 489 (new-active2 (span-state vs2))) 490 (if #f ; debug 491 (display (list (moment now-state) result-idx 492 active1 "->" new-active1 493 active2 "->" new-active2 494 "\n"))) 495 (if (and (synced? now-state) 496 (equal? active1 active2) 497 (equal? new-active1 new-active2)) 498 (analyse-notes now-state) 499 500 ;; active states different: 501 (put 'apart))) 502 503 ;; go to the next one, if it exists. 504 (analyse-time-step (1+ result-idx))))))) 505 506 (define (analyse-a2 result-idx) 507 (if (< result-idx (vector-length result)) 508 (let* ((now-state (vector-ref result result-idx)) 509 (vs1 (car (voice-states now-state))) 510 (vs2 (cdr (voice-states now-state)))) 511 512 (define (analyse-synced-silence) 513 (let ((rests1 (if vs1 (silence-events vs1) '())) 514 (rests2 (if vs2 (silence-events vs2) '()))) 515 (cond 516 517 ;; equal rests or equal skips, but not one of each 518 ((and (= 1 (length rests1)) 519 (= 1 (length rests2)) 520 (equal? (ly:event-property (car rests1) 'class) 521 (ly:event-property (car rests2) 'class)) 522 (equal? (ly:event-property (car rests1) 'duration) 523 (ly:event-property (car rests2) 'duration))) 524 (set! (configuration now-state) 'unisilence)) 525 526 ;; rests of different durations or mixed with 527 ;; skips or multi-measure rests 528 (else 529 ;; TODO For skips, route the rest to the shared 530 ;; voice and the skip to the voice for its part? 531 (set! (configuration now-state) 'apart-silence)) 532 533 ))) 534 535 (define (analyse-unsynced-silence vs1 vs2) 536 (let ((any-mmrests1 (if vs1 (any-mmrest-events vs1) #f)) 537 (any-mmrests2 (if vs2 (any-mmrest-events vs2) #f))) 538 (cond 539 ;; If a multi-measure rest begins now while the other 540 ;; part has an ongoing multi-measure rest (or has 541 ;; ended), start displaying the one that begins now. 542 ((and any-mmrests1 543 (equal? (moment vs1) (moment now-state)) 544 (or (not vs2) any-mmrests2)) 545 (set! (configuration now-state) 'silence1)) 546 547 ;; as above with parts swapped 548 ((and any-mmrests2 549 (equal? (moment vs2) (moment now-state)) 550 (or (not vs1) any-mmrests1)) 551 (set! (configuration now-state) 'silence2)) 552 ))) 553 554 (if (or vs1 vs2) 555 (let ((notes1 (if vs1 (comparable-note-events vs1) '())) 556 (notes2 (if vs2 (comparable-note-events vs2) '()))) 557 (cond ((and (equal? (configuration now-state) 'chords) 558 (pair? notes1) 559 (equal? notes1 notes2)) 560 (set! (configuration now-state) 'unisono)) 561 562 ((synced? now-state) 563 (if (and (= 0 (length notes1)) 564 (= 0 (length notes2))) 565 (analyse-synced-silence))) 566 567 (else ;; not synchronized 568 (let* ((vss 569 (current-or-previous-voice-states now-state)) 570 (vs1 (car vss)) 571 (vs2 (cdr vss))) 572 (if (and 573 (or (not vs1) (= 0 (length (note-events vs1)))) 574 (or (not vs2) (= 0 (length (note-events vs2))))) 575 (analyse-unsynced-silence vs1 vs2)))) 576 ))) 577 (analyse-a2 (1+ result-idx))))) 578 579 (define (analyse-solo12 result-idx) 580 581 (define (previous-config vs) 582 (let* ((pvs (previous-voice-state vs)) 583 (spi (if pvs (split-index pvs) #f)) 584 (prev-split (if spi (vector-ref result spi) #f))) 585 (if prev-split 586 (configuration prev-split) 587 'apart))) 588 589 (define (put-range x a b) 590 ;; (display (list "put range " x a b "\n")) 591 (do ((i a (1+ i))) 592 ((> i b) b) 593 (set! (configuration (vector-ref result i)) x))) 594 595 (define (put x) 596 ;; (display (list "putting " x "\n")) 597 (set! (configuration (vector-ref result result-idx)) x)) 598 599 (define (current-voice-state now-state voice-num) 600 (define vs ((if (= 1 voice-num) car cdr) 601 (voice-states now-state))) 602 (if (or (not vs) (equal? (moment now-state) (moment vs))) 603 vs 604 (previous-voice-state vs))) 605 606 (define (try-solo type start-idx current-idx) 607 "Find a maximum stretch that can be marked as solo. Only set 608the mark when there are no spanners active. 609 610 return next idx to analyse. 611" 612 (if (< current-idx (vector-length result)) 613 (let* ((now-state (vector-ref result current-idx)) 614 (solo-state (current-voice-state now-state (if (equal? type 'solo1) 1 2))) 615 (silent-state (current-voice-state now-state (if (equal? type 'solo1) 2 1))) 616 (silent-notes (if silent-state (note-events silent-state) '())) 617 (solo-notes (if solo-state (note-events solo-state) '()))) 618 ;; (display (list "trying " type " at " (moment now-state) solo-state silent-state "\n")) 619 (cond ((not (equal? (configuration now-state) 'apart)) 620 current-idx) 621 ((> (length silent-notes) 0) start-idx) 622 ((not solo-state) 623 (put-range type start-idx current-idx) 624 current-idx) 625 ((and 626 (null? (span-state solo-state))) 627 628 ;; 629 ;; This includes rests. This isn't a problem: long rests 630 ;; will be shared with the silent voice, and be marked 631 ;; as unisilence. Therefore, long rests won't 632 ;; accidentally be part of a solo. 633 ;; 634 (put-range type start-idx current-idx) 635 (try-solo type (1+ current-idx) (1+ current-idx))) 636 (else 637 (try-solo type start-idx (1+ current-idx))))) 638 ;; try-solo 639 start-idx)) 640 641 (define (analyse-apart-silence result-idx) 642 "Analyse 'apart-silence starting at RESULT-IDX. Return next index." 643 644 (define (analyse-synced-apart-silence vs1 vs2) 645 (let* ((rests1 (silence-events vs1)) 646 (rests2 (silence-events vs2))) 647 (cond 648 ;; multiple rests in the same part 649 ((and (or (not (= 1 (length rests1))) 650 (not (= 1 (length rests2))))) 651 (put 'apart-silence)) 652 653 ;; rest with multi-measure rest: choose the rest 654 ((and (ly:in-event-class? (car rests1) 'rest-event) 655 (ly:in-event-class? (car rests2) 'multi-measure-rest-event)) 656 (put 'silence1)) 657 658 ;; as above with parts swapped 659 ((and (ly:in-event-class? (car rests1) 'multi-measure-rest-event) 660 (ly:in-event-class? (car rests2) 'rest-event)) 661 (put 'silence2)) 662 663 ;; mmrest in both parts: choose the shorter one 664 ;; (equal mmrests are classified as unisilence earlier, 665 ;; so they shouldn't be seen here) 666 ((and (ly:in-event-class? (car rests1) 'multi-measure-rest-event) 667 (ly:in-event-class? (car rests2) 'multi-measure-rest-event)) 668 (if (ly:duration<? (ly:event-property (car rests1) 'duration) 669 (ly:event-property (car rests2) 'duration)) 670 (put 'silence1) 671 (put 'silence2))) 672 673 (else 674 (put 'apart-silence))))) 675 676 (define (analyse-unsynced-apart-silence vs1 vs2) 677 (let* ((prev-state (if (> result-idx 0) 678 (vector-ref result (- result-idx 1)) 679 #f)) 680 (prev-config (if prev-state 681 (configuration prev-state) 682 'apart-silence))) 683 (cond 684 ;; remain in the silence1/2 states until resync 685 ((equal? prev-config 'silence1) 686 (put 'silence1)) 687 688 ((equal? prev-config 'silence2) 689 (put 'silence2)) 690 691 (else 692 (put 'apart-silence))))) 693 694 (let* ((now-state (vector-ref result result-idx)) 695 (vs1 (current-voice-state now-state 1)) 696 (vs2 (current-voice-state now-state 2))) 697 (cond 698 ;; part 1 has ended 699 ((or (not vs1) (done? vs1)) 700 (put 'silence2)) 701 702 ;; part 2 has ended 703 ((or (not vs2) (done? vs2)) 704 (put 'silence1)) 705 706 ((synced? now-state) 707 (analyse-synced-apart-silence vs1 vs2)) 708 709 (else 710 (analyse-unsynced-apart-silence vs1 vs2))) 711 712 (1+ result-idx))) 713 714 (define (analyse-apart result-idx) 715 "Analyse 'apart starting at RESULT-IDX. Return next index." 716 (let* ((now-state (vector-ref result result-idx)) 717 (vs1 (current-voice-state now-state 1)) 718 (vs2 (current-voice-state now-state 2)) 719 ;; (vs1 (car (voice-states now-state))) 720 ;; (vs2 (cdr (voice-states now-state))) 721 (notes1 (if vs1 (note-events vs1) '())) 722 (notes2 (if vs2 (note-events vs2) '())) 723 (n1 (length notes1)) 724 (n2 (length notes2))) 725 ;; (display (list "analyzing step " result-idx " moment " (moment now-state) vs1 vs2 "\n")) 726 (max 727 ;; we should always increase. 728 (cond ((and (= n1 0) (= n2 0)) 729 ;; If we hit this, it means that the previous passes 730 ;; have designated as 'apart what is really 731 ;; 'apart-silence. 732 (analyse-apart-silence result-idx)) 733 ((and (= n2 0) 734 (equal? (moment vs1) (moment now-state)) 735 (null? (previous-span-state vs1))) 736 (try-solo 'solo1 result-idx result-idx)) 737 ((and (= n1 0) 738 (equal? (moment vs2) (moment now-state)) 739 (null? (previous-span-state vs2))) 740 (try-solo 'solo2 result-idx result-idx)) 741 742 (else (1+ result-idx))) 743 ;; analyse-moment 744 (1+ result-idx)))) 745 746 (if (< result-idx (vector-length result)) 747 (let ((conf (configuration (vector-ref result result-idx)))) 748 (cond 749 ((equal? conf 'apart) 750 (analyse-solo12 (analyse-apart result-idx))) 751 ((equal? conf 'apart-silence) 752 (analyse-solo12 (analyse-apart-silence result-idx))) 753 (else 754 (analyse-solo12 (1+ result-idx))))))) ; analyse-solo12 755 756 (analyse-spanner-states voice-state-vec1) 757 (analyse-spanner-states voice-state-vec2) 758 (if #f 759 (begin 760 (display voice-state-vec1) 761 (display "***\n") 762 (display voice-state-vec2) 763 (display "***\n") 764 (display result) 765 (display "***\n"))) 766 767 ;; Extract all forced combine strategies, i.e. events inserted by 768 ;; \partCombine(Apart|Automatic|SoloI|SoloII|Chords)[Once] 769 ;; They will in the end override the automaically determined ones. 770 ;; Initial state for both voices is no override 771 (analyse-forced-combine 0 #f) 772 ;; Now go through all time steps in a loop and find a combination strategy 773 ;; based only on the events of that one moment (i.e. neglecting longer 774 ;; periods of solo/apart, etc.) 775 (analyse-time-step 0) 776 ;; (display result) 777 ;; Check for unisono or unisilence moments 778 (analyse-a2 0) 779 ;;(display result) 780 (analyse-solo12 0) 781 ;; (display result) 782 (set! result (map 783 ;; forced-configuration overrides, if it is set 784 (lambda (x) (cons (moment x) (or (forced-configuration x) (configuration x)))) 785 (vector->list result))) 786 (if #f ;; pc-debug 787 (display result)) 788 result)) 789 790(define-public default-part-combine-mark-state-machine 791 ;; (current-state . ((split-state-event . 792 ;; (output-voice output-event next-state)) ...)) 793 '((Initial . ((solo1 . (solo SoloOneEvent Solo1)) 794 (solo2 . (solo SoloTwoEvent Solo2)) 795 (unisono . (shared UnisonoEvent Unisono)))) 796 (Solo1 . ((apart . (#f #f Initial)) 797 (chords . (#f #f Initial)) 798 (solo2 . (solo SoloTwoEvent Solo2)) 799 (unisono . (shared UnisonoEvent Unisono)))) 800 (Solo2 . ((apart . (#f #f Initial)) 801 (chords . (#f #f Initial)) 802 (solo1 . (solo SoloOneEvent Solo1)) 803 (unisono . (shared UnisonoEvent Unisono)))) 804 (Unisono . ((apart . (#f #f Initial)) 805 (chords . (#f #f Initial)) 806 (solo1 . (solo SoloOneEvent Solo1)) 807 (solo2 . (solo SoloTwoEvent Solo2)))))) 808 809(define-public (make-part-combine-marks state-machine split-list) 810 "Generate a sequence of part combiner events from a split list." 811 812 (define (get-state state-name) 813 (assq-ref state-machine state-name)) 814 815 (let ((full-seq '()) ; sequence of { \context Voice = "x" {} ... } 816 (segment '()) ; sequence within \context Voice = "x" {...} 817 (prev-moment ZERO-MOMENT) 818 (prev-voice #f) 819 (state (get-state 'Initial))) 820 821 (define (commit-segment) 822 "Add the current segment to the full sequence and begin another." 823 (if (pair? segment) 824 (set! full-seq 825 (cons (make-music 'ContextSpeccedMusic 826 'context-id (symbol->string prev-voice) 827 'context-type 'Voice 828 'element (make-sequential-music (reverse! segment))) 829 full-seq))) 830 (set! segment '())) 831 832 (define (handle-split split) 833 (let* ((moment (car split)) 834 (action (assq-ref state (cdr split)))) 835 (if action 836 (let ((voice (car action)) 837 (part-combine-event (cadr action)) 838 (next-state-name (caddr action))) 839 (if part-combine-event 840 (let ((dur (ly:moment-sub moment prev-moment))) 841 ;; start a new segment when the voice changes 842 (if (not (eq? voice prev-voice)) 843 (begin 844 (commit-segment) 845 (set! prev-voice voice))) 846 (if (not (equal? dur ZERO-MOMENT)) 847 (set! segment (cons (make-music 'SkipEvent 848 'duration (make-duration-of-length dur)) segment))) 849 (set! segment (cons (make-music part-combine-event) segment)) 850 851 (set! prev-moment moment))) 852 (set! state (get-state next-state-name)))))) 853 854 (for-each handle-split split-list) 855 (commit-segment) 856 (make-sequential-music (reverse! full-seq)))) 857 858(define-public default-part-combine-context-change-state-machine-one 859 ;; (current-state . ((split-state-event . (output-voice next-state)) ...)) 860 '((Initial . ((apart . (one . Initial)) 861 (apart-silence . (one . Initial)) 862 (apart-spanner . (one . Initial)) 863 (chords . (shared . Initial)) 864 (silence1 . (shared . Initial)) 865 (silence2 . (null . Demoted)) 866 (solo1 . (solo . Initial)) 867 (solo2 . (null . Demoted)) 868 (unisono . (shared . Initial)) 869 (unisilence . (shared . Initial)))) 870 871 ;; After a part has been used as the exclusive input for a 872 ;; passage, we want to use it by default for unisono/unisilence 873 ;; passages because Part_combine_iterator might have killed 874 ;; multi-measure rests in the other part. Here we call such a 875 ;; part "promoted". Part one begins promoted. 876 (Demoted . ((apart . (one . Demoted)) 877 (apart-silence . (one . Demoted)) 878 (apart-spanner . (one . Demoted)) 879 (chords . (shared . Demoted)) 880 (silence1 . (shared . Initial)) 881 (silence2 . (null . Demoted)) 882 (solo1 . (solo . Initial)) 883 (solo2 . (null . Demoted)) 884 (unisono . (null . Demoted)) 885 (unisilence . (null . Demoted)))))) 886 887(define-public default-part-combine-context-change-state-machine-two 888 ;; (current-state . ((split-state-event . (output-voice next-state)) ...)) 889 '((Initial . ((apart . (two . Initial)) 890 (apart-silence . (two . Initial)) 891 (apart-spanner . (two . Initial)) 892 (chords . (shared . Initial)) 893 (silence1 . (null . Initial)) 894 (silence2 . (shared . Promoted)) 895 (solo1 . (null . Initial)) 896 (solo2 . (solo . Promoted)) 897 (unisono . (null . Initial)) 898 (unisilence . (null . Initial)))) 899 900 ;; See the part-one state machine for the meaning of "promoted". 901 (Promoted . ((apart . (two . Promoted)) 902 (apart-silence . (two . Promoted)) 903 (apart-spanner . (two . Promoted)) 904 (chords . (shared . Promoted)) 905 (silence1 . (null . Initial)) 906 (silence2 . (shared . Promoted)) 907 (solo1 . (null . Initial)) 908 (solo2 . (solo . Promoted)) 909 (unisono . (shared . Promoted)) 910 (unisilence . (shared . Promoted)))))) 911 912(define-public (make-part-combine-context-changes state-machine split-list) 913 "Generate a sequence of part combiner context changes from a split list." 914 915 (define (get-state state-name) 916 (assq-ref state-machine state-name)) 917 918 (let* ((change-list '()) 919 (prev-moment 920 ;; the start moment is in the first entry of the split list 921 (if (and (pair? split-list) (pair? (car split-list))) 922 (caar split-list) 923 ZERO-MOMENT)) 924 (prev-change-moment prev-moment) 925 (prev-voice #f) 926 (state (get-state 'Initial))) 927 928 (define (handle-split split) 929 (let* ((moment (car split)) 930 (action (assq-ref state (cdr split)))) 931 (if action 932 (let ((voice (car action)) 933 (next-state-name (cdr action))) 934 (if (not (eq? voice prev-voice)) 935 (begin 936 (set! change-list 937 (cons (skip-of-moment-span prev-change-moment moment) 938 change-list)) 939 (set! change-list 940 (cons (make-music 941 'ContextChange 942 'change-tag '$partCombine 943 'change-to-type 'Voice 944 'change-to-id (symbol->string voice)) 945 change-list)) 946 (set! prev-change-moment moment) 947 (set! prev-voice voice))) 948 (set! prev-moment moment) 949 (set! state (get-state next-state-name)))))) 950 951 ;; (display split-list) 952 (for-each handle-split split-list) 953 ;; add a final skip so that the length of the music is correct 954 (set! change-list (cons (skip-of-moment-span prev-change-moment prev-moment) 955 change-list)) 956 (let ((result (make-sequential-music (reverse! change-list)))) 957 ;; (display-lily-music result) 958 result))) 959 960;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 961 962(define-public (add-quotable name mus) 963 (let* ((tab (eval 'musicQuotes (current-module))) 964 (voicename (get-next-unique-voice-name)) 965 ;; recording-group-emulate returns an assoc list (reversed!), so 966 ;; hand it a proper unique context name and extract that key: 967 (ctx-spec (context-spec-music mus 'Voice voicename)) 968 (listener (ly:parser-lookup 'partCombineListener)) 969 (context-list (reverse (recording-group-emulate ctx-spec listener))) 970 (raw-voice (assoc voicename context-list)) 971 (quote-contents (and raw-voice (reverse! (cdr raw-voice))))) 972 973 (define (has-events? e) 974 (and (pair? e) 975 (pair? (car e)) 976 (pair? (cdar e)))) 977 978 ;; If the context-specced quoted music does not contain anything, try to 979 ;; use the first child, i.e. the next in context-list after voicename 980 ;; That's the case e.g. for \addQuote "x" \relative c \new Voice {...} 981 ;; 982 ;; Note that if raw-voice is #f, so is quote-contents, in which 983 ;; case the following loop is skipped. 984 (if (not (has-events? quote-contents)) 985 (let find-non-empty ((current-tail (member raw-voice context-list))) 986 ;; if voice has contents, use them, otherwise check next ctx 987 (if (null? current-tail) 988 #f 989 (let ((candidate (and (pair? (car current-tail)) 990 (pair? (cdar current-tail)) 991 (reverse! (cdar current-tail))))) 992 (if (has-events? candidate) 993 (set! quote-contents candidate) 994 (find-non-empty (cdr current-tail))))))) 995 996 (if (has-events? quote-contents) 997 (hash-set! tab name (list->vector quote-contents)) 998 (ly:music-warning mus (_ "quoted music `~a' is empty") name)))) 999