scm/part-combiner.scm

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