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   ;; spanner-state is an alist
  19   ;; of (SYMBOL . RESULT-INDEX), which indicates where
  20   ;; said spanner was started.
  21   (spanner-state #:init-value '() #:accessor span-state) )
  22
  23 (define-method (write (x <Voice-state> ) file)
  24   (display (when x) file)
  25   (display " evs = " file)
  26   (display (events x) file)
  27   (display " active = " file)
  28   (display (span-state x) file)
  29   (display "\n" file) )
  30
  31 (define-method (note-events (vs <Voice-state>))
  32   (define (f? x)
  33     (equal? (ly:music-property  x 'name) 'NoteEvent))
  34   (filter f? (events vs)))
  35
  36 (define-method (previous-voice-state (vs <Voice-state>))
  37   (let ((i (slot-ref vs 'vector-index))
  38         (v (slot-ref vs 'state-vector)) )
  39     (if (< 0 i)
  40         (vector-ref v (1- i))
  41         #f)))
  42
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44
  45 (define-class <Split-state> ()
  46   (configuration #:init-value '() #:accessor configuration)
  47   (when-moment #:accessor when #:init-keyword #:when)
  48   ;; voice-states are states starting with the Split-state or later
  49   ;;
  50   (is #:init-keyword #:voice-states #:accessor voice-states)
  51   (synced  #:init-keyword #:synced #:init-value  #f #:getter synced?))
  52
  53
  54 (define-method (write (x <Split-state> ) f)
  55   (display (when x) f)
  56   (display " = " f)
  57   (display (configuration x) f)
  58   (if (synced? x)
  59       (display " synced "))
  60   (display "\n" f) )
  61
  62 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  63
  64
  65 (define (previous-span-state vs)
  66   (let ((p (previous-voice-state vs)))
  67     (if p (span-state p) '())))
  68
  69 (define (make-voice-states evl)
  70   (let ((vec (list->vector (map (lambda (v)
  71                                   (make <Voice-state>
  72                                     #:when (caar v)
  73                                     #:tuning (cdar v)
  74                                     #:events (map car (cdr v))))
  75                                 evl))))
  76     (do ( (i 0 (1+ i)) )
  77         ( (= i (vector-length vec)) vec)
  78       (slot-set! (vector-ref vec i) 'vector-index i)
  79       (slot-set! (vector-ref vec i) 'state-vector vec))))
  80
  81 (define (make-split-state vs1 vs2)
  82   "Merge lists VS1 and VS2, containing Voice-state objects into vector
  83 of Split-state objects, crosslinking the Split-state vector and
  84 Voice-state objects
  85 "
  86   (define (helper ss-idx ss-list idx1 idx2)
  87     (let* ((state1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f))
  88            (state2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f))
  89            (min (cond ((and state1 state2) (moment-min (when state1) (when state2)))
  90                       (state1 (when state1))
  91                       (state2 (when state2))
  92                       (else #f)))
  93            (inc1 (if (and state1 (equal? min (when state1))) 1 0))
  94            (inc2 (if (and state2 (equal? min (when state2))) 1 0))
  95            (ss-object (if min
  96                           (make <Split-state>
  97                             #:when min
  98                             #:voice-states (cons state1 state2)
  99                             #:synced (= inc1 inc2))
 100                           #f)))
 101       (if state1
 102           (set! (split-index state1) ss-idx))
 103       (if state2
 104           (set! (split-index state2) ss-idx))
 105       (if min
 106           (helper (1+ ss-idx)
 107                   (cons ss-object ss-list)
 108                   (+ idx1 inc1)
 109                   (+ idx2 inc2))
 110           ss-list)))
 111   (list->vector (reverse! (helper 0 '() 0  0) '())))
 112
 113
 114 (define (analyse-spanner-states voice-state-vec)
 115
 116   (define (helper index active)
 117     "Analyse EVS at INDEX, given state ACTIVE."
 118
 119     (define (analyse-tie-start active ev)
 120       (if (equal? (ly:music-property ev 'name) 'TieEvent)
 121           (acons 'tie (split-index (vector-ref voice-state-vec index))
 122                  active)
 123           active))
 124
 125     (define (analyse-tie-end active ev)
 126       (if (equal? (ly:music-property ev 'name) 'NoteEvent)
 127           (assoc-remove! active 'tie)
 128           active))
 129
 130     (define (analyse-absdyn-end active ev)
 131       (if (equal? (ly:music-property ev 'name) 'AbsoluteDynamicEvent)
 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:music-property ev 'name))
 142              (key (cond ((equal? name 'SlurEvent) 'slur)
 143                         ((equal? name 'PhrasingSlurEvent) 'tie)
 144                         ((equal? name 'BeamEvent) 'beam)
 145                         ((equal? name 'CrescendoEvent) 'cresc)
 146                         ((equal? name 'DecrescendoEvent) 'decr)
 147                         (else #f)))
 148              (sp (ly:music-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                       active evs)
 174        active<?))
 175
 176     ;; must copy, since we use assoc-remove!
 177     (if (< index (vector-length voice-state-vec))
 178         (begin
 179           (set! active (analyse-events active (events (vector-ref voice-state-vec index))))
 180           (set! (span-state (vector-ref voice-state-vec index))
 181                 (list-copy active))
 182           (helper (1+ index) active))))
 183
 184   (helper 0 '()))
 185
 186
 187
 188 (define noticed '())
 189 (define part-combine-listener '())
 190
 191 ; UGH - should pass noticed setter to part-combine-listener
 192 (define-public (set-part-combine-listener x)
 193   (set! part-combine-listener x))
 194
 195 (define-public (notice-the-events-for-pc context lst)
 196   (set! noticed (acons (ly:context-id context) lst noticed)))
 197
 198 (define-public (make-part-combine-music music-list)
 199   (let ((m (make-music 'PartCombineMusic))
 200         (m1 (make-non-relative-music (context-spec-music (car music-list) 'Voice "one")))
 201         (m2  (make-non-relative-music  (context-spec-music (cadr music-list) 'Voice "two"))))
 202     (set! (ly:music-property m 'elements) (list m1 m2))
 203     (ly:run-translator m2 part-combine-listener)
 204     (ly:run-translator m1 part-combine-listener)
 205     (set! (ly:music-property m 'split-list)
 206           (determine-split-list (reverse! (cdr (assoc "one" noticed)) '())
 207                                 (reverse! (cdr (assoc "two" noticed)) '())))
 208     (set! noticed '())
 209     m))
 210
 211 (define-public (determine-split-list evl1 evl2)
 212   "EVL1 and EVL2 should be ascending"
 213   (let* ((pc-debug #f)
 214          (chord-threshold 8)
 215          (voice-state-vec1 (make-voice-states evl1))
 216          (voice-state-vec2 (make-voice-states evl2))
 217          (result (make-split-state voice-state-vec1 voice-state-vec2)))
 218
 219     (define (analyse-time-step result-idx)
 220       (define (put x . index)
 221         "Put the result to X, starting from INDEX backwards.
 222
 223 Only set if not set previously.
 224 "
 225         (let ((i (if (pair? index) (car index) result-idx)))
 226           (if (and (<= 0 i)
 227                    (not (symbol? (configuration (vector-ref result i)))))
 228               (begin
 229                 (set! (configuration (vector-ref result i)) x)
 230                 (put x (1- i))))))
 231
 232       (define (copy-state-from state-vec vs)
 233         (define (copy-one-state key-idx)
 234           (let* ((idx (cdr key-idx))
 235                  (prev-ss (vector-ref result idx))
 236                  (prev (configuration prev-ss)))
 237             (if (symbol? prev)
 238                 (put prev))))
 239         (map copy-one-state (span-state vs)))
 240
 241       (define (analyse-notes now-state)
 242         (let* ((vs1 (car (voice-states now-state)))
 243                (vs2 (cdr (voice-states now-state)))
 244                (notes1 (note-events vs1))
 245                (durs1    (sort (map (lambda (x) (ly:music-property x 'duration))
 246                                     notes1)
 247                                ly:duration<?))
 248                (pitches1 (sort (map (lambda (x) (ly:music-property x 'pitch))
 249                                     notes1)
 250                                ly:pitch<?))
 251                (notes2   (note-events vs2))
 252                (durs2    (sort (map (lambda (x) (ly:music-property x 'duration))
 253                                     notes2)
 254                                ly:duration<?))
 255                (pitches2 (sort (map (lambda (x) (ly:music-property x 'pitch))
 256                                     notes2)
 257                                ly:pitch<?)))
 258           (cond ((> (length notes1) 1) (put 'apart))
 259                 ((> (length notes2) 1) (put 'apart))
 260                 ;;
 261                 ((and (= (length notes2) 1)
 262                       (= (length notes1) 0))
 263                       (put 'playing2))
 264                 ((and (= (length notes1) 1)
 265                       (= (length notes2) 0))
 266                       (put 'playing1))
 267                 ;;
 268                 ((and (= (length durs1) 1)
 269                       (= (length durs2) 1)
 270                       (not (equal? (car durs1) (car durs2))))
 271                  (put 'apart))
 272                 (else
 273                  (if (and (= (length pitches1) (length pitches2)))
 274                      (if (and (pair? pitches1)
 275                               (pair? pitches2)
 276                               (or
 277                                (< chord-threshold (ly:pitch-steps
 278                                                    (ly:pitch-diff (car pitches1)
 279                                                                   (car pitches2))))
 280
 281                                ;; voice crossings:
 282                                (> 0 (ly:pitch-steps (ly:pitch-diff (car pitches1)
 283                                                                    (car pitches2))))
 284                                ))
 285                          (put 'apart)
 286                          ;; copy previous split state from spanner state
 287                          (begin
 288                            (if (previous-voice-state vs1)
 289                                (copy-state-from voice-state-vec1
 290                                                 (previous-voice-state vs1)))
 291                            (if (previous-voice-state vs2)
 292                                (copy-state-from voice-state-vec2
 293                                                 (previous-voice-state vs2)))
 294                            (if (and (null? (span-state vs1)) (null? (span-state vs2)))
 295                                (put 'chords)))))))))
 296
 297       (if (< result-idx (vector-length result))
 298           (let* ((now-state (vector-ref result result-idx))
 299                  (vs1 (car (voice-states now-state)))
 300                  (vs2 (cdr (voice-states now-state))))
 301
 302             (cond ((not vs1) (put 'apart))
 303                   ((not vs2) (put 'apart))
 304                   (else
 305                    (let ((active1 (previous-span-state vs1))
 306                          (active2 (previous-span-state vs2))
 307                          (new-active1 (span-state vs1))
 308                          (new-active2 (span-state vs2)))
 309                      (if #f ; debug
 310                          (display (list (when now-state) result-idx
 311                                         active1 "->" new-active1
 312                                         active2 "->" new-active2
 313                                         "\n")))
 314                      (if (and (synced? now-state)
 315                               (equal? active1 active2)
 316                               (equal? new-active1 new-active2))
 317                          (analyse-notes now-state)
 318
 319                          ;; active states different:
 320                          (put 'apart)))
 321
 322                    ;; go to the next one, if it exists.
 323                    (analyse-time-step (1+ result-idx)))))))
 324
 325     (define (analyse-a2 result-idx)
 326       (if (< result-idx (vector-length result))
 327           (let* ((now-state (vector-ref result result-idx))
 328                  (vs1 (car (voice-states now-state)))
 329                  (vs2 (cdr (voice-states now-state))))
 330             (if (and (equal? (configuration now-state) 'chords)
 331                      vs1 vs2)
 332                 (let ((notes1 (note-events vs1))
 333                       (notes2 (note-events vs2)))
 334                   (cond ((and (= 1 (length notes1))
 335                               (= 1 (length notes2))
 336                               (equal? (ly:music-property (car notes1) 'pitch)
 337                                       (ly:music-property (car notes2) 'pitch)))
 338                          (set! (configuration now-state) 'unisono))
 339                         ((and (= 0 (length notes1))
 340                               (= 0 (length notes2)))
 341                          (set! (configuration now-state) 'unisilence)))))
 342             (analyse-a2 (1+ result-idx)))))
 343
 344     (define (analyse-solo12 result-idx)
 345
 346       (define (previous-config vs)
 347         (let* ((pvs (previous-voice-state vs))
 348                (spi (if pvs (split-index pvs) #f))
 349                (prev-split (if spi (vector-ref result spi) #f)))
 350           (if prev-split
 351               (configuration prev-split)
 352               'apart)))
 353
 354       (define (put-range x a b)
 355         ;; (display (list "put range "  x a b "\n"))
 356         (do ((i a (1+ i)))
 357             ((> i b) b)
 358           (set! (configuration (vector-ref result i)) x)))
 359
 360       (define (put x)
 361         ;; (display (list "putting "  x "\n"))
 362         (set! (configuration (vector-ref result result-idx)) x))
 363
 364       (define (current-voice-state now-state voice-num)
 365         (define vs ((if (= 1 voice-num) car cdr)
 366                     (voice-states now-state)))
 367         (if (or (not vs) (equal? (when now-state) (when vs)))
 368             vs
 369             (previous-voice-state vs)))
 370
 371       (define (try-solo type start-idx current-idx)
 372         "Find a maximum stretch that can be marked as solo. Only set
 373 the mark when there are no spanners active."
 374         (if (< current-idx (vector-length result))
 375             (let* ((now-state (vector-ref result current-idx))
 376                    (solo-state (current-voice-state now-state (if (equal? type 'solo1) 1 2)))
 377                    (silent-state (current-voice-state now-state (if (equal? type 'solo1) 2 1)))
 378                    (silent-notes (if silent-state (note-events silent-state) '()))
 379                    (solo-notes (if solo-state (note-events solo-state) '())))
 380               ;; (display (list "trying " type " at "  (when now-state) solo-state silent-state  "\n"))
 381               (cond ((not (equal? (configuration now-state) 'apart))
 382                      current-idx)
 383                     ((> (length silent-notes) 0) start-idx)
 384                     ((not solo-state)
 385                      (put-range type start-idx current-idx)
 386                      current-idx)
 387                     ((and
 388                       (null? (span-state solo-state)))
 389                      ;;
 390                      ;; This includes rests. This isn't a problem: long rests
 391                      ;; will be shared with the silent voice, and be marked
 392                      ;; as unisilence. Therefore, long rests won't
 393                      ;;  accidentally be part of a solo.
 394                      ;;
 395                      (put-range type start-idx current-idx)
 396                      (try-solo type (1+ current-idx) (1+  current-idx)))
 397                     (else
 398                      (try-solo type start-idx (1+ current-idx)))))
 399             start-idx)) ; try-solo
 400
 401       (define (analyse-moment result-idx)
 402         "Analyse 'apart starting at RESULT-IDX. Return next index. "
 403         (let* ((now-state (vector-ref result result-idx))
 404                (vs1 (current-voice-state now-state 1))
 405                (vs2 (current-voice-state now-state 2))
 406                ;; (vs1 (car (voice-states now-state)))
 407                ;; (vs2 (cdr (voice-states now-state)))
 408                (notes1 (if vs1 (note-events vs1) '()))
 409                (notes2 (if vs2 (note-events vs2) '()))
 410                (n1 (length notes1))
 411                (n2 (length notes2)))
 412           ;; (display (list "analyzing step " result-idx "  moment " (when now-state) vs1 vs2  "\n"))
 413           (max                          ; we should always increase.
 414
 415            (cond ((and (= n1 0) (= n2 0))
 416                   (put 'apart-silence)
 417                   (1+ result-idx))
 418                  ((and (= n2 0)
 419                        (equal? (when vs1) (when now-state))
 420                        (null? (previous-span-state vs1)))
 421                   (try-solo 'solo1 result-idx result-idx))
 422                  ((and (= n1 0)
 423                        (equal? (when vs2) (when now-state))
 424                        (null? (previous-span-state vs2)))
 425                   (try-solo 'solo2 result-idx result-idx))
 426
 427                  (else (1+ result-idx)))
 428            (1+ result-idx)))) ; analyse-moment
 429
 430       (if (< result-idx (vector-length result))
 431           (if (equal? (configuration (vector-ref result result-idx)) 'apart)
 432               (analyse-solo12 (analyse-moment result-idx))
 433               (analyse-solo12 (1+ result-idx))))) ; analyse-solo12
 434
 435     (analyse-spanner-states voice-state-vec1)
 436     (analyse-spanner-states voice-state-vec2)
 437     (if #f
 438         (begin
 439           (display voice-state-vec1)
 440           (display "***\n")
 441           (display voice-state-vec2)
 442           (display "***\n")
 443           (display result)
 444           (display "***\n")))
 445     (analyse-time-step 0)
 446     ;; (display result)
 447     (analyse-a2 0)
 448     ;;(display result)
 449     (analyse-solo12 0)
 450     ;; (display result)
 451     (set! result (map
 452                   (lambda (x) (cons (when x) (configuration x)))
 453                   (vector->list result)))
 454     (if #f ;; pc-debug
 455          (display result))
 456     result))
 457
 458 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 459 ;; autochange - fairly related to part combining.
 460
 461 (define-public (make-autochange-music music)
 462   (define (generate-split-list change-moment event-list acc)
 463     (if (null? event-list)
 464         acc
 465         (let* ((now-tun (caar event-list))
 466                (evs (map car (cdar event-list)))
 467                (now (car now-tun))
 468                (notes (filter (lambda (x)
 469                                 (equal? (ly:music-property  x 'name) 'NoteEvent))
 470                               evs))
 471                (pitch (if (pair? notes)
 472                           (ly:music-property (car notes) 'pitch)
 473                           #f)))
 474           ;; tail recursive.
 475           (if (and pitch (not (= (ly:pitch-steps pitch) 0)))
 476               (generate-split-list #f
 477                                    (cdr event-list)
 478                                    (cons (cons
 479
 480                                           (if change-moment
 481                                               change-moment
 482                                               now)
 483                                           (sign (ly:pitch-steps pitch))) acc))
 484               (generate-split-list
 485                (if pitch #f now)
 486                (cdr event-list) acc)))))
 487
 488   (set! noticed '())
 489   (let* ((m (make-music 'AutoChangeMusic))
 490          (context (ly:run-translator (make-non-relative-music music) part-combine-listener))
 491          (evs (last-pair noticed))
 492          (split (reverse! (generate-split-list
 493                            #f
 494                            (if (pair? evs)
 495                                (reverse! (cdar evs) '()) '())
 496                            '())
 497                           '())))
 498     (set! (ly:music-property m 'element) music)
 499     (set! (ly:music-property m 'split-list) split)
 500     (set! noticed '())
 501     m))
 502
 503
 504 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 505
 506 (define-public (add-quotable name mus)
 507   (set! noticed '())
 508   (let* ((tab (eval 'musicQuotes (current-module) ))
 509          (context (ly:run-translator (context-spec-music mus 'Voice)
 510                                      part-combine-listener))
 511          (evs (last-pair noticed)))
 512     (if (pair? evs)
 513         (hash-set! tab name
 514                    ;; cdr : skip name string
 515                    (list->vector (reverse! (cdar evs) '()))))))
 516