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