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