common/reduction.ily

   1 %%% -*- Mode: Scheme -*-
   2 %%% Based on:
   3 %%% part-combiner.scm -- Part combining, staff changes.
   4 %%%
   5 %%%  source file of the GNU LilyPond music typesetter
   6 %%%
   7 %%% (c) 2004--2007      Han-Wen Nienhuys <hanwen@xs4all.nl>
   8 #(use-modules (oop goops))
   9 #(define-class <Voice-state> ()
  10    (event-list #:init-value '() #:accessor events #:init-keyword #:events)
  11    (when-moment #:accessor when #:init-keyword #:when)
  12    (tuning #:accessor tuning #:init-keyword #:tuning)
  13    (split-index #:accessor split-index)
  14    (vector-index)
  15    (state-vector)
  16   ;;;
  17    ;; spanner-state is an alist
  18    ;; of (SYMBOL . RESULT-INDEX), which indicates where
  19    ;; said spanner was started.
  20    (spanner-state #:init-value '() #:accessor span-state))
  21
  22 #(define-method (write (x <Voice-state> ) file)
  23    (display (when x) file)
  24    (display " evs = " file)
  25    (display (events x) file)
  26    (display " active = " file)
  27    (display (span-state x) file)
  28    (display "\n" file))
  29
  30 #(define-method (note-events (vs <Voice-state>))
  31    (define (f? x)
  32      (equal? (ly:event-property x 'class) 'note-event))
  33    (filter f? (events vs)))
  34
  35 #(define-method (previous-voice-state (vs <Voice-state>))
  36    (let ((i (slot-ref vs 'vector-index))
  37          (v (slot-ref vs 'state-vector)))
  38      (if (< 0 i)
  39          (vector-ref v (1- i))
  40          #f)))
  41
  42 %%%;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43
  44 #(define-class <Split-state> ()
  45    (configuration #:init-value '() #:accessor configuration)
  46    (when-moment #:accessor when #:init-keyword #:when)
  47    ;; voice-states are states starting with the Split-state or later
  48    ;;
  49    (is #:init-keyword #:voice-states #:accessor voice-states)
  50    (synced  #:init-keyword #:synced #:init-value         #f #:getter synced?))
  51
  52
  53 #(define-method (write (x <Split-state> ) f)
  54    (display (when x) f)
  55    (display " = " f)
  56    (display (configuration x) f)
  57    (if (synced? x)
  58        (display " synced "))
  59    (display "\n" f))
  60
  61 %%%;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  62
  63
  64 #(define (previous-span-state vs)
  65    (let ((p (previous-voice-state vs)))
  66      (if p (span-state p) '())))
  67
  68 #(define (make-voice-states evl)
  69    (let ((vec (list->vector (map (lambda (v)
  70                                    (make <Voice-state>
  71                                      #:when (caar v)
  72                                      #:tuning (cdar v)
  73                                      #:events (map car (cdr v))))
  74                                  evl))))
  75      (do ((i 0 (1+ i)))
  76          ((= i (vector-length vec)) vec)
  77        (slot-set! (vector-ref vec i) 'vector-index i)
  78        (slot-set! (vector-ref vec i) 'state-vector vec))))
  79
  80 #(define (make-split-state vs1 vs2)
  81    "Merge lists VS1 and VS2, containing Voice-state objects into vector
  82 of Split-state objects, crosslinking the Split-state vector and
  83 Voice-state objects
  84 "
  85    (define (helper ss-idx ss-list idx1 idx2)
  86      (let* ((state1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f))
  87             (state2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f))
  88             (min (cond ((and state1 state2) (moment-min (when state1) (when state2)))
  89                        (state1 (when state1))
  90                        (state2 (when state2))
  91                        (else #f)))
  92             (inc1 (if (and state1 (equal? min (when state1))) 1 0))
  93             (inc2 (if (and state2 (equal? min (when state2))) 1 0))
  94             (ss-object (if min
  95                            (make <Split-state>
  96                              #:when min
  97                              #:voice-states (cons state1 state2)
  98                              #:synced (= inc1 inc2))
  99                            #f)))
 100        (if state1
 101            (set! (split-index state1) ss-idx))
 102        (if state2
 103            (set! (split-index state2) ss-idx))
 104        (if min
 105            (helper (1+ ss-idx)
 106                    (cons ss-object ss-list)
 107                    (+ idx1 inc1)
 108                    (+ idx2 inc2))
 109            ss-list)))
 110    (list->vector (reverse! (helper 0 '() 0  0) '())))
 111
 112 #(define (analyse-spanner-states voice-state-vec)
 113
 114    (define (helper index active)
 115      "Analyse EVS at INDEX, given state ACTIVE."
 116
 117      (define (analyse-tie-start active ev)
 118        (if (equal? (ly:event-property ev 'class) 'tie-event)
 119            (acons 'tie (split-index (vector-ref voice-state-vec index))
 120                   active)
 121            active))
 122
 123      (define (analyse-tie-end active ev)
 124        (if (equal? (ly:event-property ev 'class) 'note-event)
 125            (assoc-remove! active 'tie)
 126            active))
 127
 128      (define (analyse-absdyn-end active ev)
 129        (if (or (equal? (ly:event-property ev 'class) 'absolute-dynamic-event)
 130                (and (equal? (ly:event-property ev 'class) 'crescendo-event)
 131                     (equal? STOP (ly:event-property ev 'span-direction))))
 132            (assoc-remove! (assoc-remove! active 'cresc) 'decr)
 133            active))
 134
 135      (define (active<? a b)
 136        (cond ((symbol<? (car a) (car b)) #t)
 137              ((symbol<? (car b) (car b)) #f)
 138              (else (< (cdr a) (cdr b)))))
 139
 140      (define (analyse-span-event active ev)
 141        (let* ((name (ly:event-property ev 'class))
 142               (key (cond ;((equal? name 'slur-event) 'slur)
 143                          ((equal? name 'phrasing-slur-event) 'tie)
 144                          ((equal? name 'beam-event) 'beam)
 145                          ((equal? name 'crescendo-event) 'cresc)
 146                          ((equal? name 'decrescendo-event) 'decr)
 147                          (else #f)))
 148               (sp (ly:event-property ev 'span-direction)))
 149          (if (and (symbol? key) (ly:dir? sp))
 150              (if (= sp STOP)
 151                  (assoc-remove! active key)
 152                  (acons key
 153                         (split-index (vector-ref voice-state-vec index))
 154                         active))
 155              active)))
 156
 157      (define (analyse-events active evs)
 158        "Run all analyzers on ACTIVE and EVS"
 159        (define (run-analyzer analyzer active evs)
 160          (if (pair? evs)
 161              (run-analyzer analyzer (analyzer active (car evs)) (cdr evs))
 162              active))
 163        (define (run-analyzers analyzers active evs)
 164          (if (pair? analyzers)
 165              (run-analyzers (cdr analyzers)
 166                             (run-analyzer (car analyzers) active evs)
 167                             evs)
 168              active))
 169        (sort ;; todo: use fold or somesuch.
 170         (run-analyzers (list analyse-absdyn-end analyse-span-event
 171                              ;; note: tie-start/span comes after tie-end/absdyn.
 172                              ;;analyse-tie-end analyse-tie-start
 173                              )
 174                        active evs)
 175         active<?))
 176
 177      ;; must copy, since we use assoc-remove!
 178      (if (< index (vector-length voice-state-vec))
 179          (begin
 180            (set! active (analyse-events active (events (vector-ref voice-state-vec index))))
 181            (set! (span-state (vector-ref voice-state-vec index))
 182                  (list-copy active))
 183            (helper (1+ index) active))))
 184
 185    (helper 0 '()))
 186
 187 %%%;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 188 #(define-public (recording-group-emulate music odef)
 189    "Interprets music according to odef, but stores all events in a chronological list, similar to the Recording_group_engraver in 2.8 and earlier"
 190    (let*
 191        ((context-list '())
 192         (now-mom (ly:make-moment 0 0))
 193         (global (ly:make-global-context odef))
 194         (mom-listener (ly:make-listener
 195                        (lambda (tev)
 196                          (set! now-mom (ly:event-property tev 'moment)))))
 197         (new-context-listener
 198          (ly:make-listener
 199           (lambda (sev)
 200             (let*
 201                 ((child (ly:event-property sev 'context))
 202                  (this-moment-list
 203                   (cons (ly:context-id child) '()))
 204                  (dummy
 205                   (set! context-list (cons this-moment-list context-list)))
 206                  (acc '())
 207                  (accumulate-event-listener
 208                   (ly:make-listener (lambda (ev)
 209                                       (set! acc (cons (cons ev #t) acc)))))
 210                  (save-acc-listener (ly:make-listener (lambda (tev)
 211                                                         (if (pair? acc)
 212                                                             (let ((this-moment (cons (cons now-mom (ly:context-property child 'instrumentTransposition))
 213                                                                                      acc)))
 214                                                               (set-cdr! this-moment-list (cons this-moment (cdr this-moment-list)))
 215                                                               (set! acc '())))))))
 216               (ly:add-listener accumulate-event-listener (ly:context-event-source child) 'music-event)
 217               (ly:add-listener save-acc-listener (ly:context-event-source global) 'OneTimeStep))))))
 218      (ly:add-listener new-context-listener (ly:context-events-below global) 'AnnounceNewContext)
 219      (ly:add-listener mom-listener (ly:context-event-source global) 'Prepare)
 220      (ly:interpret-music-expression (make-non-relative-music music) global)
 221      context-list))
 222
 223 #(define-public (make-part-combine-music parser music-list)
 224    (let* ((m (make-music 'PartCombineMusic))
 225           (m1 (make-non-relative-music (context-spec-music (first music-list) 'Voice "one")))
 226           (m2  (make-non-relative-music  (context-spec-music (second music-list) 'Voice "two")))
 227           (listener (ly:parser-lookup parser 'partCombineListener))
 228           (evs2 (recording-group-emulate m2 listener))
 229           (evs1 (recording-group-emulate m1 listener)))
 230
 231      (set! (ly:music-property m 'elements) (list m1 m2))
 232      (set! (ly:music-property m 'split-list)
 233            (if (and (assoc "one" evs1) (assoc "two" evs2))
 234                (determine-split-list (reverse! (cdr (assoc "one" evs1)) '())
 235                                      (reverse! (cdr (assoc "two" evs2)) '()))
 236                '() ))
 237      m))
 238
 239 #(define-public (determine-split-list evl1 evl2)
 240    "EVL1 and EVL2 should be ascending"
 241    (let* ((pc-debug #f)
 242           (chord-threshold 8)
 243           (voice-state-vec1 (make-voice-states evl1))
 244           (voice-state-vec2 (make-voice-states evl2))
 245           (result (make-split-state voice-state-vec1 voice-state-vec2)))
 246
 247      (define (analyse-time-step result-idx)
 248        (define (put x . index)
 249          "Put the result to X, starting from INDEX backwards.
 250 Only set if not set previously."
 251          (let ((i (if (pair? index) (car index) result-idx)))
 252            (if (and (<= 0 i)
 253                     (not (symbol? (configuration (vector-ref result i)))))
 254                (begin
 255                  (set! (configuration (vector-ref result i)) x)
 256                  (put x (1- i))))))
 257
 258        (define (copy-state-from state-vec vs)
 259          (define (copy-one-state key-idx)
 260            (let* ((idx (cdr key-idx))
 261                   (prev-ss (vector-ref result idx))
 262                   (prev (configuration prev-ss)))
 263              (if (symbol? prev)
 264                  (put prev))))
 265          (map copy-one-state (span-state vs)))
 266
 267        (define (analyse-notes now-state)
 268          (let* ((vs1 (car (voice-states now-state)))
 269                 (vs2 (cdr (voice-states now-state)))
 270                 (notes1 (note-events vs1))
 271                 (durs1 (sort (map (lambda (x) (ly:event-property x 'duration))
 272                                   notes1)
 273                              ly:duration<?))
 274                 (pitches1 (sort (map (lambda (x) (ly:event-property x 'pitch))
 275                                      notes1)
 276                                 ly:pitch<?))
 277                 (notes2 (note-events vs2))
 278                 (durs2 (sort (map (lambda (x) (ly:event-property x 'duration))
 279                                   notes2)
 280                              ly:duration<?))
 281                 (pitches2 (sort (map (lambda (x) (ly:event-property x 'pitch))
 282                                      notes2)
 283                                 ly:pitch<?)))
 284            (cond ((> (length notes1) 1) (put 'apart))
 285                  ((> (length notes2) 1) (put 'apart))
 286                  ((= 1 (+ (length notes2) (length notes1))) (put 'apart))
 287                  ((and (= (length durs1) 1)
 288                        (= (length durs2) 1)
 289                        (not (equal? (car durs1) (car durs2))))
 290                   (put 'apart))
 291                  (else
 292                   (if (and (= (length pitches1) (length pitches2)))
 293                       (if (and (pair? pitches1)
 294                                (pair? pitches2)
 295                                (< chord-threshold
 296                                   (ly:pitch-steps
 297                                    (ly:pitch-diff (car pitches1)
 298                                                   (car pitches2)))))
 299                           (put 'apart)
 300                           ;; copy previous split state from spanner state
 301                           (begin
 302                             (if (previous-voice-state vs1)
 303                                 (copy-state-from voice-state-vec1
 304                                                  (previous-voice-state vs1)))
 305                             (if (previous-voice-state vs2)
 306                                 (copy-state-from voice-state-vec2
 307                                                  (previous-voice-state vs2)))
 308                             (if (and (null? (span-state vs1)) (null? (span-state vs2)))
 309                                 (put 'chords)))))))))
 310        (if (< result-idx (vector-length result))
 311            (let* ((now-state (vector-ref result result-idx))
 312                   (vs1 (car (voice-states now-state)))
 313                   (vs2 (cdr (voice-states now-state))))
 314              (cond ((not vs1) (put 'apart))
 315                    ((not vs2) (put 'apart))
 316                    (else
 317                     (let ((active1 (previous-span-state vs1))
 318                           (active2 (previous-span-state vs2))
 319                           (new-active1 (span-state vs1))
 320                           (new-active2 (span-state vs2)))
 321                       (if (and (synced? now-state)
 322                                (equal? active1 active2)
 323                                (equal? new-active1 new-active2))
 324                           (analyse-notes now-state)
 325                           ;; active states different:
 326                           (put 'apart)))
 327                     ;; go to the next one, if it exists.
 328                     (analyse-time-step (1+ result-idx)))))))
 329
 330      (define (analyse-a2 result-idx)
 331        (if (< result-idx (vector-length result))
 332            (let* ((now-state (vector-ref result result-idx))
 333                   (vs1 (car (voice-states now-state)))
 334                   (vs2 (cdr (voice-states now-state))))
 335              (if (and (equal? (configuration now-state) 'chords)
 336                       vs1 vs2)
 337                  (let ((notes1 (note-events vs1))
 338                        (notes2 (note-events vs2)))
 339                    (cond ((and (= 1 (length notes1))
 340                                (= 1 (length notes2))
 341                                (equal? (ly:event-property (car notes1) 'pitch)
 342                                        (ly:event-property (car notes2) 'pitch)))
 343                           (set! (configuration now-state) 'unisono))
 344                          ((and (= 0 (length notes1))
 345                                (= 0 (length notes2)))
 346                           (set! (configuration now-state) 'unisilence)))))
 347              (analyse-a2 (1+ result-idx)))))
 348
 349      (define (analyse-solo12 result-idx)
 350
 351        (define (previous-config vs)
 352          (let* ((pvs (previous-voice-state vs))
 353                 (spi (if pvs (split-index pvs) #f))
 354                 (prev-split (if spi (vector-ref result spi) #f)))
 355            (if prev-split
 356                (configuration prev-split)
 357                'apart)))
 358
 359        (define (put-range x a b)
 360          ;; (display (list "put range " x a b "\n"))
 361          (do ((i a (1+ i)))
 362              ((> i b) b)
 363            (set! (configuration (vector-ref result i)) x)))
 364
 365        (define (put x)
 366          ;; (display (list "putting "  x "\n"))
 367          (set! (configuration (vector-ref result result-idx)) x))
 368
 369        (define (current-voice-state now-state voice-num)
 370          (define vs ((if (= 1 voice-num) car cdr)
 371                      (voice-states now-state)))
 372          (if (or (not vs) (equal? (when now-state) (when vs)))
 373              vs
 374              (previous-voice-state vs)))
 375
 376        (define (try-solo type start-idx current-idx)
 377          "Find a maximum stretch that can be marked as solo. Only set
 378 the mark when there are no spanners active.
 379
 380       return next idx to analyse.
 381 "
 382          (if (< current-idx (vector-length result))
 383              (let* ((now-state (vector-ref result current-idx))
 384                     (solo-state (current-voice-state now-state (if (equal? type 'solo1) 1 2)))
 385                     (silent-state (current-voice-state now-state (if (equal? type 'solo1) 2 1)))
 386                     (silent-notes (if silent-state (note-events silent-state) '()))
 387                     (solo-notes (if solo-state (note-events solo-state) '())))
 388                (cond ((not (equal? (configuration now-state) 'apart))
 389                       current-idx)
 390                      ((> (length silent-notes) 0) start-idx)
 391                      ((not solo-state)
 392                       (put-range type start-idx current-idx)
 393                       current-idx)
 394                      ((and
 395                        (null? (span-state solo-state)))
 396                       ;;
 397                       ;; This includes rests. This isn't a problem: long rests
 398                       ;; will be shared with the silent voice, and be marked
 399                       ;; as unisilence. Therefore, long rests won't
 400                       ;;         accidentally be part of a solo.
 401                       ;;
 402                       (put-range type start-idx current-idx)
 403                       (try-solo type (1+ current-idx) (1+  current-idx)))
 404                      (else
 405                       (try-solo type start-idx (1+ current-idx)))))
 406              ;; try-solo
 407              start-idx))
 408
 409        (define (analyse-moment result-idx)
 410          "Analyse 'apart starting at RESULT-IDX. Return next index. "
 411          (let* ((now-state (vector-ref result result-idx))
 412                 (vs1 (current-voice-state now-state 1))
 413                 (vs2 (current-voice-state now-state 2))
 414                 (notes1 (if vs1 (note-events vs1) '()))
 415                 (notes2 (if vs2 (note-events vs2) '()))
 416                 (n1 (length notes1))
 417                 (n2 (length notes2)))
 418            (max
 419             ;; we should always increase.
 420             (cond ((and (= n1 0) (= n2 0))
 421                    (put 'apart-silence)
 422                    (1+ result-idx))
 423                   ((and (= n2 0)
 424                         (equal? (when vs1) (when now-state))
 425                         (null? (previous-span-state vs1)))
 426                    (try-solo 'solo1 result-idx result-idx))
 427                   ((and (= n1 0)
 428                         (equal? (when vs2) (when now-state))
 429                         (null? (previous-span-state vs2)))
 430                    (try-solo 'solo2 result-idx result-idx))
 431
 432                   (else (1+ result-idx)))
 433             ;; analyse-moment
 434             (1+ result-idx))))
 435
 436        (if (< result-idx (vector-length result))
 437            (if (equal? (configuration (vector-ref result result-idx)) 'apart)
 438                (analyse-solo12 (analyse-moment result-idx))
 439                (analyse-solo12 (1+ result-idx))))) ; analyse-solo12
 440
 441      (analyse-spanner-states voice-state-vec1)
 442      (analyse-spanner-states voice-state-vec2)
 443      (analyse-time-step 0)
 444      (analyse-a2 0)
 445      (analyse-solo12 0)
 446      (set! result (map
 447                    (lambda (x) (cons (when x) (configuration x)))
 448                    (vector->list result)))
 449      result))
 450
 451 %%%
 452
 453 #(define-public (add-quotable parser name mus)
 454    (let* ((tab (eval 'musicQuotes (current-module)))
 455           (context-list (recording-group-emulate (context-spec-music mus 'Voice)
 456                                                  (ly:parser-lookup parser 'partCombineListener))))
 457      (if (pair? context-list)
 458          (hash-set! tab name
 459                     ;; cdr : skip name string
 460                     (list->vector (reverse! (cdar context-list)
 461                                             '()))))))
 462
 463 reduction =
 464 #(define-music-function (parser location part1 part2) (ly:music? ly:music?)
 465    (make-part-combine-music parser (list music1 music2)))
 466
 467 %%%;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 468 %%%;;;
 469 %%%;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;#(use-modules (oop goops))
 470
 471 #(define (prob->music prob)
 472    (let ((music (make-music (ly:prob-property prob 'name))))
 473      (map (lambda (property)
 474             (set! (ly:music-property music (car property)) (cdr property)))
 475           (ly:prob-mutable-properties prob))
 476      music))
 477
 478 #(define (partcombine->music music1 music2 layout)
 479    (let* ((context-list '())
 480           (result (list))
 481           (now-mom (ly:make-moment 0 0))
 482           (global (ly:make-global-context layout))
 483           (mom-listener (ly:make-listener
 484                          (lambda (tev)
 485                            (set! now-mom (ly:event-property tev 'moment)))))
 486           (new-context-listener
 487            (ly:make-listener
 488             (lambda (sev)
 489               (let*
 490                   ((child (ly:event-property sev 'context))
 491                    (musics (list))
 492                    (accumulate-event-listener
 493                     (ly:make-listener (lambda (ev)
 494                                         (if (ly:prob? (ly:event-property ev 'music-cause))
 495                                             (set! musics
 496                                                   (cons (prob->music (ly:event-property ev 'music-cause))
 497                                                         musics))))))
 498                    (save-acc-listener (ly:make-listener
 499                                        (lambda (tev)
 500                                          (if (pair? musics)
 501                                              (begin
 502                                                (set! result (cons (list (string->symbol (ly:context-id child))
 503                                                                         now-mom
 504                                                                         (reverse! musics))
 505                                                                   result))
 506                                                (set! musics (list))))))))
 507                 (ly:add-listener accumulate-event-listener (ly:context-event-source child) 'music-event)
 508                 (ly:add-listener save-acc-listener (ly:context-event-source global) 'OneTimeStep))))))
 509      (ly:add-listener new-context-listener (ly:context-events-below global) 'AnnounceNewContext)
 510      (ly:add-listener mom-listener (ly:context-event-source global) 'Prepare)
 511      (ly:interpret-music-expression (make-part-combine-music parser (list music1 music2)) global)
 512      (reverse! result)))
 513
 514 #(define (duration->moment ly-duration)
 515    (let* ((log2  (ly:duration-log ly-duration))
 516           (dots  (ly:duration-dot-count ly-duration))
 517           (num.den (ly:duration-factor ly-duration))
 518           (num (car num.den))
 519           (den (cdr num.den)))
 520      (if (= 0 num)
 521          (ly:make-moment 0 0)
 522          (let ((rational-moment (let* ((m (expt 2 (- log2)))
 523                                        (factor (/ num den)))
 524                                   (/ (do ((i 0 (1+ i))
 525                                           (delta (/ m 2) (/ delta 2)))
 526                                          ((= i dots) m)
 527                                        (set! m (+ m delta)))
 528                                      factor))))
 529            (ly:make-moment (numerator rational-moment)
 530                            (denominator rational-moment))))))
 531
 532 #(define (moment->duration moment)
 533    ;; this is not correct
 534    (ly:make-duration 0 0 (ly:moment-main-numerator moment) (ly:moment-main-denominator moment)))
 535
 536 #(define (music-duration music)
 537    (let ((this-duration (ly:music-property music 'duration)))
 538      (if (ly:duration? this-duration)
 539          this-duration
 540          (let* ((child (ly:music-property music 'element))
 541                 (child-duration (and (ly:music? child) (music-duration child))))
 542            (if (ly:duration? child-duration)
 543                child-duration
 544                (let loop ((children (ly:music-property music 'elements)))
 545                  (if (null? children)
 546                      #f
 547                      (let ((child-duration (music-duration (car children))))
 548                        (if (ly:duration? child-duration)
 549                            child-duration
 550                            (loop (cdr children)))))))))))
 551
 552 #(define-class <music-accumulator> ()
 553    (music-events #:init-value '() #:accessor events-of)
 554    (last-moment #:init-value (ly:make-moment 0 0) #:accessor last-moment-of))
 555
 556 #(define-method (add-music-event (music-acc <music-accumulator>) music-event moment)
 557    (let* ((last-music-duration (and (not (null? (events-of music-acc)))
 558                                     (music-duration (car (events-of music-acc)))))
 559           (skip-moment (ly:moment-sub (ly:moment-sub moment (last-moment-of music-acc))
 560                                       (if (ly:duration? last-music-duration)
 561                                           (duration->moment last-music-duration)
 562                                           (ly:make-moment 0 0))))
 563           (skip-duration (moment->duration skip-moment)))
 564      (if (and (not (= 0 (ly:moment-main-numerator skip-moment))) (ly:duration? skip-duration))
 565          (set! (events-of music-acc)
 566                (cons (make-music 'EventChord 'elements
 567                                  (list (make-music 'SkipEvent 'duration skip-duration)))
 568                      (events-of music-acc))))
 569      (set! (last-moment-of music-acc) moment)
 570      (set! (events-of music-acc) (cons music-event (events-of music-acc)))))
 571
 572 #(define-method (music-sequence (music-acc <music-accumulator>))
 573    (make-music 'SequentialMusic 'elements (reverse (events-of music-acc))))
 574
 575 #(define-method (music-voice (music-acc <music-accumulator>) name)
 576    (make-music 'ContextSpeccedMusic
 577                'create-new #t
 578                'property-operations '()
 579                'context-id name
 580                'context-type 'Voice
 581                'element (music-sequence music-acc)))
 582
 583 #(define (combine-two-musics music1 music2)
 584    (let ((music-acc  (make <music-accumulator>))
 585          (music-acc2 (make <music-accumulator>)))
 586      (map (lambda (id-mom-musics)
 587             (let* ((id (first id-mom-musics))
 588                    (moment (second id-mom-musics))
 589                    (music-events (third id-mom-musics))
 590                    (music (make-music 'EventChord 'elements music-events)))
 591               (case id
 592                 ((two) (add-music-event music-acc2 music moment))
 593                 ((one shared solo) (add-music-event music-acc music moment)))))
 594           (partcombine->music music1 music2 $defaultlayout))
 595      (list (music-sequence music-acc)
 596            (music-sequence music-acc2))))
 597
 598 reductionB =
 599 #(define-music-function (parser location part1 part2) (ly:music? ly:music?)
 600    (let* ((seqs1+2 (combine-two-musics part1 part2))
 601           (notes1+2 (first seqs1+2))
 602           (notes2 (second seqs1+2)))
 603      #{ << $notes1+2 $notes2 >> #}))