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* ((s1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f))
  88            (s2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f))
  89            (min (cond ((and s1 s2) (moment-min (when s1) (when s2)))
  90                       (s1 (when s1))
  91                       (s2 (when s2))
  92                       (else #f)))
  93            (inc1 (if (and s1 (equal? min (when s1))) 1 0))
  94            (inc2 (if (and s2 (equal? min (when s2))) 1 0))
  95            (ss-object (if min
  96                           (make <Split-state>
  97                             #:when min
  98                             #:voice-states (cons s1 s2)
  99                             #:synced (= inc1 inc2))
 100                           #f)))
 101       (if s1
 102           (set! (split-index s1) ss-idx))
 103       (if s2
 104           (set! (split-index s2) 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 index active)
 122           active))
 123
 124     (define (analyse-tie-end active ev)
 125       (if (equal? (ly:music-property ev 'name) 'NoteEvent)
 126           (assoc-remove! active 'tie)
 127           active))
 128
 129     (define (analyse-absdyn-end active ev)
 130       (if (equal? (ly:music-property ev 'name) 'AbsoluteDynamicEvent)
 131           (assoc-remove! (assoc-remove! active 'cresc) 'decr)
 132           active))
 133
 134     (define (active<? a b)
 135       (cond ((symbol<? (car a) (car b)) #t)
 136             ((symbol<? (car b) (car b)) #f)
 137             (else (< (cdr a) (cdr b)))))
 138
 139     (define (analyse-span-event active ev)
 140       (let* ((name (ly:music-property ev 'name))
 141              (key (cond ((equal? name 'SlurEvent) 'slur)
 142                         ((equal? name 'PhrasingSlurEvent) 'tie)
 143                         ((equal? name 'BeamEvent) 'beam)
 144                         ((equal? name 'CrescendoEvent) 'cresc)
 145                         ((equal? name 'DecrescendoEvent) 'decr)
 146                         (else #f)))
 147              (sp (ly:music-property ev 'span-direction)))
 148         (if (and (symbol? key) (ly:dir? sp))
 149             (if (= sp STOP)
 150                 (assoc-remove! active key)
 151                 (acons key
 152                        (split-index (vector-ref voice-state-vec index))
 153                        active))
 154             active)))
 155
 156     (define (analyse-events active evs)
 157       "Run all analyzers on ACTIVE and EVS"
 158       (define (run-analyzer analyzer active evs)
 159         (if (pair? evs)
 160             (run-analyzer analyzer (analyzer active (car evs)) (cdr evs))
 161             active))
 162       (define (run-analyzers analyzers active evs)
 163         (if (pair? analyzers)
 164             (run-analyzers (cdr analyzers)
 165                            (run-analyzer (car analyzers) active evs)
 166                            evs)
 167             active))
 168       (sort ;; todo: use fold or somesuch.
 169        (run-analyzers (list analyse-absdyn-end analyse-span-event
 170                             ;; note: tie-start/span comes after tie-end/absdyn.
 171                             analyse-tie-end analyse-tie-start)
 172                       active evs)
 173        active<?))
 174
 175     ;; must copy, since we use assoc-remove!
 176     (if (< index (vector-length voice-state-vec))
 177         (begin
 178           (set! active (analyse-events active (events (vector-ref voice-state-vec index))))
 179           (set! (span-state (vector-ref voice-state-vec index))
 180                 (list-copy active))
 181           (helper (1+ index) active))))
 182
 183   (helper 0 '()))
 184
 185
 186
 187 (define noticed '())
 188 (define part-combine-listener '())
 189 (define-public (set-part-combine-listener x)
 190   (set! part-combine-listener x))
 191
 192 (define-public (notice-the-events-for-pc context lst)
 193   (set! noticed (acons (ly:context-id context) lst noticed)))
 194
 195 (define-public (make-part-combine-music music-list)
 196   (let ((m (make-music 'PartCombineMusic))
 197         (m1 (make-non-relative-music (context-spec-music (car music-list) 'Voice "one")))
 198         (m2  (make-non-relative-music  (context-spec-music (cadr music-list) 'Voice "two"))))
 199     (set! (ly:music-property m 'elements) (list m1 m2))
 200     (ly:run-translator m2 part-combine-listener)
 201     (ly:run-translator m1 part-combine-listener)
 202     (set! (ly:music-property m 'split-list)
 203           (determine-split-list (reverse! (cdr (assoc "one" noticed)) '())
 204                                 (reverse! (cdr (assoc "two" noticed)) '())))
 205     (set! noticed '())
 206     m))
 207
 208 (define-public (determine-split-list evl1 evl2)
 209   "EVL1 and EVL2 should be ascending"
 210   (let* ((pc-debug #f)
 211          (chord-threshold 8)
 212          (voice-state-vec1 (make-voice-states evl1))
 213          (voice-state-vec2 (make-voice-states evl2))
 214          (result (make-split-state voice-state-vec1 voice-state-vec2)))
 215
 216     (define (analyse-time-step ri)
 217       (define (put x . index)
 218         "Put the result to X, starting from INDEX backwards.
 219
 220 Only set if not set previously.
 221 "
 222         (let ((i (if (pair? index) (car index) ri)))
 223           (if (and (<= 0 i)
 224                    (not (symbol? (configuration (vector-ref result i)))))
 225               (begin
 226                 (set! (configuration (vector-ref result i)) x)
 227                 (put x (1- i))))))
 228
 229       (define (copy-state-from state-vec vs)
 230         (define (copy-one-state key-idx)
 231           (let* ((idx (cdr key-idx))
 232                  (prev-ss (vector-ref result idx))
 233                  (prev (configuration prev-ss)))
 234             (if (symbol? prev)
 235                 (put prev))))
 236         (map copy-one-state (span-state vs)))
 237
 238       (define (analyse-notes now-state)
 239         (let* ((vs1 (car (voice-states now-state)))
 240                (vs2 (cdr (voice-states now-state)))
 241                (notes1 (note-events vs1))
 242                (durs1    (sort (map (lambda (x) (ly:music-property x 'duration))
 243                                     notes1)
 244                                ly:duration<?))
 245                (pitches1 (sort (map (lambda (x) (ly:music-property x 'pitch))
 246                                     notes1)
 247                                ly:pitch<?))
 248                (notes2   (note-events vs2))
 249                (durs2    (sort (map (lambda (x) (ly:music-property x 'duration))
 250                                     notes2)
 251                                ly:duration<?))
 252                (pitches2 (sort (map (lambda (x) (ly:music-property x 'pitch))
 253                                     notes2)
 254                                ly:pitch<?)))
 255           (cond ((> (length notes1) 1) (put 'apart))
 256                 ((> (length notes2) 1) (put 'apart))
 257                 ((not (= (length notes1) (length notes2)))
 258                  (put 'apart))
 259                 ((and (= (length durs1) 1)
 260                       (= (length durs2) 1)
 261                       (not (equal? (car durs1) (car durs2))))
 262                  (put 'apart))
 263                 (else
 264                  (if (and (= (length pitches1) (length pitches2)))
 265                      (if (and (pair? pitches1)
 266                               (pair? pitches2)
 267                               (or
 268                                (< chord-threshold (ly:pitch-steps
 269                                                    (ly:pitch-diff (car pitches1)
 270                                                                   (car pitches2))))
 271
 272                                ;; voice crossings:
 273                                (> 0 (ly:pitch-steps (ly:pitch-diff (car pitches1)
 274                                                                    (car pitches2))))
 275                                ))
 276                          (put 'apart)
 277                          ;; copy previous split state from spanner state
 278                          (begin
 279                            (if (previous-voice-state vs1)
 280                                (copy-state-from voice-state-vec1
 281                                                 (previous-voice-state vs1)))
 282                            (if (previous-voice-state vs2)
 283                                (copy-state-from voice-state-vec2
 284                                                 (previous-voice-state vs2)))
 285                            (if (and (null? (span-state vs1)) (null? (span-state vs2)))
 286                                (put 'chords)))))))))
 287
 288       (if (< ri (vector-length result))
 289           (let* ((now-state (vector-ref result ri))
 290                  (vs1 (car (voice-states now-state)))
 291                  (vs2 (cdr (voice-states now-state))))
 292             (cond ((not vs1) (put 'apart))
 293                   ((not vs2) (put 'apart))
 294                   (else
 295                    (let ((active1 (previous-span-state vs1))
 296                          (active2 (previous-span-state vs2))
 297                          (new-active1 (span-state vs1))
 298                          (new-active2 (span-state vs2)))
 299                      (if pc-debug
 300                          (display (list (when now-state) ri
 301                                         active1 "->" new-active1
 302                                         active2 "->" new-active2
 303                                         "\n")))
 304                      (if (and (synced? now-state)
 305                               (equal? active1 active2)
 306                               (equal? new-active1 new-active2))
 307                     (analyse-notes now-state)
 308                     ;; active states different:
 309                     (put 'apart)))
 310                    ;; go to the next one, if it exists.
 311                    (analyse-time-step (1+ ri)))))))
 312
 313     (define (analyse-a2 ri)
 314       (if (< ri (vector-length result))
 315           (let* ((now-state (vector-ref result ri))
 316                  (vs1 (car (voice-states now-state)))
 317                  (vs2 (cdr (voice-states now-state))))
 318             (if (and (equal? (configuration now-state) 'chords)
 319                      vs1 vs2)
 320                 (let ((notes1 (note-events vs1))
 321                       (notes2 (note-events vs2)))
 322                   (cond ((and (= 1 (length notes1))
 323                               (= 1 (length notes2))
 324                               (equal? (ly:music-property (car notes1) 'pitch)
 325                                       (ly:music-property (car notes2) 'pitch)))
 326                          (set! (configuration now-state) 'unisono))
 327                         ((and (= 0 (length notes1))
 328                               (= 0 (length notes2)))
 329                          (set! (configuration now-state) 'unisilence)))))
 330             (analyse-a2 (1+ ri)))))
 331
 332     (define (analyse-solo12 ri)
 333
 334       (define (previous-config vs)
 335         (let* ((pvs (previous-voice-state vs))
 336                (spi (if pvs (split-index pvs) #f))
 337                (prev-split (if spi (vector-ref result spi) #f)))
 338           (if prev-split
 339               (configuration prev-split)
 340               'apart)))
 341
 342       (define (put-range x a b)
 343         ;; (display (list "put range "  x a b "\n"))
 344         (do ((i a (1+ i)))
 345             ((> i b) b)
 346           (set! (configuration (vector-ref result i)) x)))
 347
 348       (define (put x)
 349         ;; (display (list "putting "  x "\n"))
 350         (set! (configuration (vector-ref result ri)) x))
 351
 352       (define (current-voice-state now-state voice-num)
 353         (define vs ((if (= 1 voice-num) car cdr)
 354                     (voice-states now-state)))
 355         (if (or (not vs) (equal? (when now-state) (when vs)))
 356             vs
 357             (previous-voice-state vs)))
 358
 359       (define (try-solo type start-idx current-idx)
 360         "Find a maximum stretch that can be marked as solo. Only set
 361 the mark when there are no spanners active."
 362         (if (< current-idx (vector-length result))
 363             (let* ((now-state (vector-ref result current-idx))
 364                    (solo-state (current-voice-state now-state (if (equal? type 'solo1) 1 2)))
 365                    (silent-state (current-voice-state now-state (if (equal? type 'solo1) 2 1)))
 366                    (silent-notes (if silent-state (note-events silent-state) '()))
 367                    (solo-notes (if solo-state (note-events solo-state) '()))
 368                    (soln (length solo-notes))
 369                    (siln (length silent-notes)))
 370               ;; (display (list "trying " type " at "  (when now-state) solo-state silent-state  "\n"))
 371               (cond ((not (equal? (configuration now-state) 'apart))
 372                      current-idx)
 373                     ((> siln 0) start-idx)
 374                     ((and (null? (span-state solo-state)))
 375                      ;;
 376                      ;; This includes rests. This isn't a problem: long rests
 377                      ;; will be shared with the silent voice, and be marked
 378                      ;; as unisilence. Therefore, long rests won't
 379                      ;;  accidentally be part of a solo.
 380                      ;;
 381                      (put-range type start-idx current-idx)
 382                      (try-solo type (1+ current-idx) (1+  current-idx)))
 383                     (else
 384                      (try-solo type start-idx (1+ current-idx)))))
 385             start-idx)) ; try-solo
 386
 387       (define (analyse-moment ri)
 388         "Analyse 'apart starting at RI. Return next index. "
 389         (let* ((now-state (vector-ref result ri))
 390                (vs1 (current-voice-state now-state 1))
 391                (vs2 (current-voice-state now-state 2))
 392                ;; (vs1 (car (voice-states now-state)))
 393                ;; (vs2 (cdr (voice-states now-state)))
 394                (notes1 (if vs1 (note-events vs1) '()))
 395                (notes2 (if vs2 (note-events vs2) '()))
 396                (n1 (length notes1))
 397                (n2 (length notes2)))
 398           ;; (display (list "analyzing step " ri "  moment " (when now-state) vs1 vs2  "\n"))
 399           (max                          ; we should always increase.
 400            (cond ((and (= n1 0) (= n2 0))
 401                   (put 'apart-silence)
 402                   (1+ ri))
 403                  ((and (= n2 0)
 404                        (equal? (when vs1) (when now-state))
 405                        (null? (previous-span-state vs1)))
 406                   (try-solo 'solo1 ri ri))
 407                  ((and (= n1 0)
 408                        (equal? (when vs2) (when now-state))
 409                        (null? (previous-span-state vs2)))
 410                   (try-solo 'solo2 ri ri))
 411                  (else (1+ ri)))
 412            (1+ ri)))) ; analyse-moment
 413
 414       (if (< ri (vector-length result))
 415           (if (equal? (configuration (vector-ref result ri)) 'apart)
 416               (analyse-solo12 (analyse-moment ri))
 417               (analyse-solo12 (1+ ri))))) ; analyse-solo12
 418
 419     (analyse-spanner-states voice-state-vec1)
 420     (analyse-spanner-states voice-state-vec2)
 421     (if #f
 422         (begin
 423           (display voice-state-vec1)
 424           (display "***\n")
 425           (display voice-state-vec2)
 426           (display "***\n")
 427           (display result)
 428           (display "***\n")))
 429     (analyse-time-step 0)
 430     ;; (display result)
 431     (analyse-a2 0)
 432     ;; (display result)
 433     (analyse-solo12 0)
 434     ;; (display result)
 435     (set! result (map
 436                   (lambda (x) (cons (when x) (configuration x)))
 437                   (vector->list result)))
 438     ;; (if pc-debug (display result))
 439     result))
 440
 441 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 442 ;; autochange - fairly related to part combining.
 443
 444 (define-public (make-autochange-music music)
 445   (define (generate-split-list change-moment event-list acc)
 446     (if (null? event-list)
 447         acc
 448         (let* ((now-tun (caar event-list))
 449                (evs (map car (cdar event-list)))
 450                (now (car now-tun))
 451                (notes (filter (lambda (x)
 452                                 (equal? (ly:music-property  x 'name) 'NoteEvent))
 453                               evs))
 454                (pitch (if (pair? notes)
 455                           (ly:music-property (car notes) 'pitch)
 456                           #f)))
 457           ;; tail recursive.
 458           (if (and pitch (not (= (ly:pitch-steps pitch) 0)))
 459               (generate-split-list #f
 460                                    (cdr event-list)
 461                                    (cons (cons
 462
 463                                           (if change-moment
 464                                               change-moment
 465                                               now)
 466                                           (sign (ly:pitch-steps pitch))) acc))
 467               (generate-split-list
 468                (if pitch #f now)
 469                (cdr event-list) acc)))))
 470
 471   (set! noticed '())
 472   (let* ((m (make-music 'AutoChangeMusic))
 473          (context (ly:run-translator (make-non-relative-music music) part-combine-listener))
 474          (evs (last-pair noticed))
 475          (split (reverse! (generate-split-list
 476                            #f
 477                            (if (pair? evs)
 478                                (reverse! (cdar evs) '()) '())
 479                            '())
 480                           '())))
 481     (set! (ly:music-property m 'element) music)
 482     (set! (ly:music-property m 'split-list) split)
 483     (set! noticed '())
 484     m))
 485
 486
 487 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 488
 489 (define-public (add-quotable name mus)
 490   (set! noticed '())
 491   (let* ((tab (eval 'musicQuotes (current-module) ))
 492          (context (ly:run-translator (context-spec-music mus 'Voice)
 493                                      part-combine-listener))
 494          (evs (last-pair noticed)))
 495     (if (pair? evs)
 496         (hash-set! tab name
 497                    (list->vector (reverse! (car evs) '()))))))