scm/part-combiner.scm

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