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