scm/part-combiner.scm

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