scm/part-combiner.scm

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