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