scm/part-combiner.scm

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