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 (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
 182         (if (and (symbol? key) (ly:dir? sp))
 183             (if (= sp STOP)
 184                 (assoc-remove! active key)
 185                 (acons key index active))
 186             active)
 187         ))
 188
 189     (define (analyse-events active evs)
 190       "Run all analyzers on ACTIVE and EVS"
 191
 192       (define (run-analyzer analyzer active evs)
 193         (if (pair? evs)
 194             (run-analyzer analyzer (analyzer active (car evs)) (cdr evs))
 195             active
 196             ))
 197       (define (run-analyzers analyzers active evs)
 198         (if (pair? analyzers)
 199             (run-analyzers
 200              (cdr analyzers)
 201              (run-analyzer (car analyzers) active evs)
 202              evs)
 203             active
 204         ))
 205
 206
 207
 208       (sort
 209
 210        ;; todo: use fold or somesuch.
 211        (run-analyzers
 212         (list analyse-span-event
 213               ;; note: tie-start comes after tie-end.
 214               analyse-tie-end analyse-tie-start analyse-absdyn-end)
 215
 216          active evs)
 217
 218        active<?))
 219
 220     ;; must copy, since we use assoc-remove!
 221     (if (< index (vector-length voice-state-vec))
 222         (begin
 223           (set! active (analyse-events active (events (vector-ref voice-state-vec index))))
 224           (set! (span-state (vector-ref voice-state-vec index))
 225                 (list-copy active))
 226
 227           (helper (1+ index) active)))
 228     )
 229
 230
 231   (helper 0 '())
 232
 233   )
 234
 235
 236
 237 (define noticed '())
 238 (define part-combine-listener '())
 239 (define-public (set-part-combine-listener x)
 240   (set! part-combine-listener x))
 241
 242 (define-public (notice-the-events-for-pc context lst)
 243   (set! noticed (acons (ly:context-id context) lst noticed)))
 244
 245 (define-public (make-new-part-combine-music music-list)
 246   (let*
 247      ((m (make-music-by-name 'NewPartCombineMusic))
 248       (m1 (context-spec-music (car music-list) 'Voice "one"))
 249       (m2 (context-spec-music (cadr music-list) 'Voice "two"))
 250       (props '((denies Thread)
 251                (consists Rest_engraver)
 252                (consists Note_heads_engraver)
 253                )))
 254
 255     (ly:set-mus-property! m 'elements (list m1 m2))
 256     (ly:set-mus-property! m1 'property-operations props)
 257     (ly:set-mus-property! m2 'property-operations props)
 258     (ly:run-translator m2 part-combine-listener)
 259     (ly:run-translator m1 part-combine-listener)
 260     (ly:set-mus-property! m 'split-list
 261                          (determine-split-list (reverse (cdr (assoc "one" noticed)))
 262                                                (reverse (cdr (assoc "two" noticed)))))
 263     (set! noticed '())
 264
 265     m))
 266
 267
 268
 269
 270
 271
 272
 273 (define-public (determine-split-list evl1 evl2)
 274   "EVL1 and EVL2 should be ascending"
 275
 276
 277
 278   (let*
 279       ((pc-debug #f)
 280        (chord-threshold 8)
 281        (voice-state-vec1 (make-voice-states evl1))
 282        (voice-state-vec2 (make-voice-states evl2))
 283        (result (make-split-state voice-state-vec1 voice-state-vec2))
 284        )
 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              (start-vs (vector-ref state-vec idx))
 311              (prev-ss (vector-ref result (split-idx start-vs)))
 312              (prev (configuration prev-ss))
 313              )
 314           (if (symbol? prev)
 315               (put prev))))
 316
 317       (map copy-one-state (span-state vs))
 318       )
 319
 320     (define (analyse-notes now-state)
 321       (let*
 322           (
 323            (vs1 (car (voice-states now-state)))
 324            (vs2 (cdr (voice-states now-state)))
 325
 326            (notes1 (note-events vs1))
 327            (durs1 (sort (map (lambda (x) (ly:get-mus-property x 'duration)) notes1) ly:duration<?))
 328            (pitches1 (sort
 329                       (map (lambda (x) (ly:get-mus-property x 'pitch)) notes1) ly:pitch<?))
 330            (notes2 (note-events vs2))
 331            (durs2     (sort (map (lambda (x) (ly:get-mus-property x 'duration)) notes2) ly:duration<?))
 332            (pitches2 (sort
 333                       (map (lambda (x) (ly:get-mus-property x 'pitch)) notes2) ly:pitch<?))
 334            )
 335
 336         (cond
 337          ((> (length notes1) 1) (put 'apart))
 338          ((> (length notes2) 1) (put 'apart))
 339          ((not (= (length notes1) (length notes2)))
 340           (put 'apart))
 341          ((and
 342            (= (length durs1) 1)
 343            (= (length durs2) 1)
 344            (not (equal? (car durs1) (car durs2))))
 345
 346           (put 'apart))
 347          (else
 348           (if (and (= (length pitches1) (length pitches2)))
 349               (if (and (pair? pitches1)
 350                        (pair? pitches2)
 351                        (< chord-threshold (ly:pitch-steps
 352                                            (ly:pitch-diff (car pitches1) (car pitches2)))))
 353                   (put 'apart)
 354
 355                   ;; copy previous split state from spanner state
 356                   (begin
 357                     (if (previous-voice-state vs1)
 358                         (copy-state-from voice-state-vec1
 359                                          (previous-voice-state vs1)))
 360                     (if (previous-voice-state vs2)
 361                         (copy-state-from voice-state-vec2
 362                                          (previous-voice-state vs2)))
 363                     (if (and (null? (span-state vs1)) (null? (span-state vs2)))
 364                         (put 'chords))
 365
 366                     ))))
 367          )))
 368
 369
 370
 371     (if (< ri (vector-length result))
 372         (let*
 373             ((now-state (vector-ref result ri))
 374              (vs1 (car (voice-states now-state)))
 375              (vs2 (cdr (voice-states now-state))))
 376
 377           (cond
 378            ((not vs1) (put 'apart))
 379            ((not vs2) (put 'apart))
 380            (else
 381             (let*
 382                 (
 383                  (active1 (previous-span-state vs1))
 384                  (active2 (previous-span-state vs2))
 385
 386                  (new-active1 (span-state vs1))
 387                  (new-active2 (span-state vs2))
 388
 389                  )
 390               (if
 391                pc-debug
 392                (display (list (when now-state) ri
 393                                     active1 "->" new-active1
 394                                     active2 "->" new-active2
 395                                     "\n")))
 396
 397
 398
 399               (if (and (synced? now-state)
 400                        (equal? active1 active2)
 401                        (equal? new-active1 new-active2))
 402
 403                   (analyse-notes now-state)
 404
 405                   ;; active states different:
 406                   (put 'apart)
 407                   )
 408               )
 409
 410                                         ; go to the next one, if it exists.
 411             (analyse-time-step (1+ ri))
 412             )))))
 413
 414   (define (analyse-a2 ri)
 415     (if (< ri (vector-length result))
 416         (let*
 417             ((now-state (vector-ref result ri))
 418              (vs1 (car (voice-states now-state)))
 419              (vs2 (cdr (voice-states now-state)))
 420              )
 421
 422           (if (and (equal? (configuration now-state) 'chords)
 423                    vs1 vs2)
 424
 425               (let*
 426                   ((notes1 (note-events vs1))
 427                    (notes2 (note-events vs2))
 428                    )
 429                 (cond
 430                  ((and
 431                    (= 1 (length notes1))
 432                    (= 1 (length notes2))
 433                    (equal? (ly:get-mus-property (car notes1) 'pitch)
 434                            (ly:get-mus-property (car notes2) 'pitch)))
 435
 436                   (set! (configuration now-state) 'unisono))
 437                  ((and
 438                    (= 0 (length notes1))
 439                    (= 0 (length notes2)))
 440                   (set! (configuration now-state) 'unisilence)))
 441
 442                 ))
 443           (analyse-a2 (1+ ri))
 444
 445           )))
 446
 447    (define (analyse-solo12 ri)
 448
 449      (define (previous-config vs)
 450        (let*  ((pvs (previous-voice-state vs))
 451                (spi (if pvs (split-idx pvs) #f))
 452                (prev-split (if spi (vector-ref result spi) #f))
 453                )
 454
 455          (if prev-split
 456              (configuration prev-split)
 457              'apart)
 458
 459        ))
 460      (define (put-range x a b)
 461        (do
 462            ((i a (1+ i)))
 463            ((> i b) b)
 464          (set! (configuration (vector-ref result i)) x)
 465          ))
 466      (define (put x)
 467        (set! (configuration (vector-ref result ri)) x))
 468
 469      (define (try-solo type start-idx current-idx)
 470        (if (< current-idx (vector-length result))
 471            (let*
 472                ((now-state (vector-ref result current-idx))
 473                 (solo-state ((if (equal? type 'solo1) car cdr) (voice-states now-state)))
 474                 (silent-state ((if (equal? type 'solo1) cdr car) (voice-states now-state)))
 475                 (silent-notes (note-events silent-state))
 476                 (solo-notes (note-events solo-state))
 477                 (soln (length solo-notes))
 478                 (siln (length silent-notes)))
 479
 480              (cond
 481               ((not (equal? (configuration now-state) 'apart))
 482                current-idx)
 483               ((= soln 0) current-idx)
 484               ((> siln 0) current-idx)
 485               ((null? (span-state solo-state))
 486                (put-range type start-idx current-idx)
 487                current-idx)
 488               (else
 489                (try-solo type start-idx (1+ current-idx)))
 490
 491               ))
 492            (1- current-idx)))
 493
 494      (define (analyse-moment ri)
 495        "Analyse 'apart  starting at RI. Return next index.
 496 "
 497
 498         (let*
 499            ((now-state (vector-ref result ri))
 500             (vs1 (car (voice-states now-state)))
 501             (vs2 (cdr (voice-states now-state)))
 502
 503             (notes1 (note-events vs1))
 504             (notes2 (note-events vs2))
 505             (n1 (length notes1))
 506             (n2 (length notes2))
 507             )
 508
 509           (cond
 510            ((and (= n1 0) (= n2 0))
 511             (put 'apart-silence)
 512             (1+ ri)
 513             )
 514
 515            ((and (= n2 0)
 516                  (equal? (when vs1) (when now-state))
 517                  (null? (previous-span-state vs1)))
 518             (try-solo 'solo1 ri ri))
 519            ((and (= n1 0)
 520                  (equal? (when vs2) (when now-state))
 521                  (null? (previous-span-state vs2)))
 522             (try-solo 'solo2 ri ri))
 523            (else
 524             (1+ ri))
 525        )))
 526
 527      (if (< ri (vector-length result))
 528          (if (equal? (configuration (vector-ref result ri)) 'apart)
 529              (analyse-solo12 (analyse-moment ri))
 530              (analyse-solo12 (1+ ri))))
 531      )
 532
 533
 534    (analyse-spanner-states voice-state-vec1)
 535    (analyse-spanner-states voice-state-vec2)
 536
 537    (if #f
 538        (begin
 539         (display voice-state-vec1)
 540         (display "***\n")
 541         (display voice-state-vec2)
 542         (display "***\n")
 543         (display result)
 544         (display "***\n")
 545         ))
 546
 547    (analyse-time-step 0)
 548    (analyse-a2 0)
 549 ;   (display result)
 550    (analyse-solo12 0)
 551 ;   (if pc-debug (display result))
 552
 553    (set! result    (map
 554                     (lambda (x) (cons (when x) (configuration x)))
 555                     (vector->list result)))
 556
 557    (if pc-debug (display result))
 558    result))