scm/music-functions.scm

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2
   3 (define-public (music-map function music)
   4   "Apply @var{function} to @var{music} and all of the music it contains. "
   5   (let* ((es (ly:get-mus-property music 'elements))
   6          (e (ly:get-mus-property music 'element))
   7          )
   8
   9     (ly:set-mus-property! music 'elements
  10         (map (lambda (y) (music-map  function y)) es))
  11         (if (ly:music? e)
  12             (ly:set-mus-property! music 'element (music-map function  e)))
  13         (function music)
  14         ))
  15
  16 (define-public (music-filter pred? music)
  17   "Filter out music expressions that do not satisfy PRED."
  18
  19   (define (inner-music-filter pred? music)
  20     "Recursive function."
  21     (let* ((es (ly:get-mus-property music 'elements))
  22            (e (ly:get-mus-property music 'element))
  23            (as (ly:get-mus-property music 'articulations))
  24            (filtered-as (filter ly:music? (map (lambda (y) (inner-music-filter pred? y)) as)))
  25            (filtered-e (if (ly:music? e)
  26                            (inner-music-filter pred? e)
  27                            e))
  28            (filtered-es (filter ly:music? (map (lambda (y) (inner-music-filter pred? y)) es)))
  29            )
  30
  31       (ly:set-mus-property! music 'element filtered-e)
  32       (ly:set-mus-property! music 'elements filtered-es)
  33       (ly:set-mus-property! music 'articulations filtered-as)
  34
  35       ;; if filtering emptied the expression, we remove it completely.
  36       (if (or (pred? music)
  37               (and (eq? filtered-es '()) (not (ly:music? e))
  38                    (or (not (eq? es '()))
  39                        (ly:music? e))))
  40           (set! music '()))
  41
  42       music))
  43
  44   (set! music (inner-music-filter pred? music))
  45   (if (ly:music? music)
  46       music
  47       (make-music-by-name 'Music)       ;must return music.
  48       ))
  49
  50 (define-public (remove-tag tag)
  51   (lambda (mus)
  52     (music-filter
  53      (lambda (m)
  54        (let* ((tags (ly:get-mus-property m 'tags))
  55               (res (memq tag tags)))
  56        res)) mus)))
  57
  58 (define-public (display-music music)
  59   "Display music, not done with music-map for clarity of presentation."
  60   (display music)
  61   (display ": { ")
  62
  63   (let* ((es (ly:get-mus-property music 'elements))
  64          (e (ly:get-mus-property music 'element))
  65          )
  66
  67     (display (ly:get-mutable-properties music))
  68
  69     (if (pair?  es)
  70         (begin (display "\nElements: {\n")
  71                (map display-music es)
  72                (display "}\n")
  73         ))
  74
  75
  76     (if (ly:music? e)
  77         (begin
  78           (display "\nChild:")
  79           (display-music e)
  80           )
  81         )
  82     )
  83   (display " }\n")
  84   music
  85   )
  86
  87
  88
  89
  90 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  91
  92 (define (shift-one-duration-log music shift dot)
  93   "  add SHIFT to ly:duration-log and optionally
  94   a dot to any note encountered. This scales the music up by a factor
  95   2^shift * (2 - (1/2)^dot)"
  96
  97   (let*
  98       (
  99        (d (ly:get-mus-property music 'duration))
 100        )
 101     (if (ly:duration? d)
 102         (let* (
 103                (cp (ly:duration-factor d))
 104                (nd (ly:make-duration (+ shift (ly:duration-log d))
 105                                      (+ dot (ly:duration-dot-count d))
 106                                      (car cp)
 107                                      (cdr cp)))
 108
 109                )
 110           (ly:set-mus-property! music 'duration nd)
 111           ))
 112     music))
 113
 114
 115
 116 (define-public (shift-duration-log music shift dot)
 117   (music-map (lambda (x) (shift-one-duration-log x shift dot))
 118              music))
 119
 120
 121 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 122 ;; clusters.
 123
 124 (define-public (note-to-cluster music)
 125   "Replace NoteEvents by ClusterNoteEvents."
 126   (if (eq? (ly:get-mus-property music 'name) 'NoteEvent)
 127       (let* ((cn (make-music-by-name 'ClusterNoteEvent)))
 128
 129              (ly:set-mus-property! cn 'pitch (ly:get-mus-property music 'pitch))
 130              (ly:set-mus-property! cn 'duration (ly:get-mus-property music 'duration))
 131              cn)
 132       music))
 133
 134 (define-public (notes-to-clusters music)
 135   (music-map note-to-cluster music))
 136
 137 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 138 ;; repeats.
 139
 140 (define-public (unfold-repeats music)
 141 "
 142 This function replaces all repeats  with unfold repeats. It was
 143 written by Rune Zedeler. "
 144   (let* ((es (ly:get-mus-property music 'elements))
 145          (e (ly:get-mus-property music 'element))
 146          (n  (ly:music-name music)))
 147
 148     (if (equal? n "Repeated_music")
 149         (begin
 150           (if (equal?
 151                (ly:get-mus-property music 'iterator-ctor)
 152                Chord_tremolo_iterator::constructor)
 153               (shift-duration-log music  (ly:intlog2 (ly:get-mus-property music 'repeat-count)) 0)
 154               )
 155           (ly:set-mus-property!
 156            music 'length Repeated_music::unfolded_music_length)
 157           (ly:set-mus-property!
 158            music 'start-moment-function Repeated_music::first_start)
 159           (ly:set-mus-property!
 160            music 'iterator-ctor Unfolded_repeat_iterator::constructor)))
 161
 162     (if (pair? es)
 163         (ly:set-mus-property!
 164          music 'elements
 165          (map unfold-repeats es)))
 166
 167     (if (ly:music? e)
 168         (ly:set-mus-property!
 169          music 'element
 170          (unfold-repeats e)))
 171
 172     music))
 173
 174
 175 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 176 ;; property setting music objs.
 177
 178 (define-public (make-grob-property-set grob gprop val)
 179
 180   "Make a Music expression that sets GPROP to VAL in GROB. Does a pop first,
 181 i.e.  this is not an override"
 182
 183    (let* ((m (make-music-by-name  'OverrideProperty)))
 184      (ly:set-mus-property! m 'symbol grob)
 185      (ly:set-mus-property! m 'grob-property gprop)
 186      (ly:set-mus-property! m 'grob-value val)
 187      (ly:set-mus-property! m 'pop-first #t)
 188
 189      m
 190
 191    ))
 192 (define-public (make-grob-property-override grob gprop val)
 193
 194   "Make a Music expression that sets GPROP to VAL in GROB. Does a pop first,
 195 i.e.  this is not an override"
 196
 197    (let* ((m (make-music-by-name  'OverrideProperty)))
 198      (ly:set-mus-property! m 'symbol grob)
 199      (ly:set-mus-property! m 'grob-property gprop)
 200      (ly:set-mus-property! m 'grob-value val)
 201
 202      m
 203
 204    ))
 205
 206
 207 (define-public (make-grob-property-revert grob gprop)
 208   "Revert the grob property GPROP for GROB."
 209    (let* ((m (make-music-by-name  'OverrideProperty)))
 210      (ly:set-mus-property! m 'symbol grob)
 211      (ly:set-mus-property! m 'grob-property gprop)
 212
 213      m
 214
 215    ))
 216
 217 (define direction-polyphonic-grobs
 218    '(Tie Slur Script TextScript Stem Dots DotColumn))
 219
 220 (define-public (make-voice-props-set n)
 221   (make-sequential-music
 222    (append
 223       (map (lambda (x) (make-grob-property-set x 'direction
 224                                                (if (odd? n) -1 1)))
 225            direction-polyphonic-grobs)
 226       (list
 227        (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2))
 228        (make-grob-property-set 'MultiMeasureRest 'staff-position
 229                                (if (odd? n) -4 4)
 230                                )
 231
 232        )
 233    )
 234   ))
 235
 236 (define-public (make-voice-props-revert)
 237   (make-sequential-music
 238    (append
 239     (map (lambda (x) (make-grob-property-revert x 'direction))
 240          direction-polyphonic-grobs)
 241
 242       (list (make-grob-property-revert 'NoteColumn 'horizontal-shift))
 243    ))
 244   )
 245
 246
 247 (define-public (context-spec-music m context . rest)
 248   "Add \\context CONTEXT = foo to M. "
 249
 250   (let* ((cm (make-music-by-name 'ContextSpeccedMusic)))
 251     (ly:set-mus-property! cm 'element m)
 252     (ly:set-mus-property! cm 'context-type context)
 253     (if (and  (pair? rest) (string? (car rest)))
 254         (ly:set-mus-property! cm 'context-id (car rest))
 255     )
 256     cm
 257   ))
 258
 259 (define-public (make-apply-context func)
 260   (let*
 261       ((m (make-music-by-name 'ApplyContext)))
 262
 263     (ly:set-mus-property! m 'procedure func)
 264     m
 265   ))
 266
 267 (define-public (make-sequential-music elts)
 268   (let*  ((m (make-music-by-name 'SequentialMusic)))
 269     (ly:set-mus-property! m 'elements elts)
 270     m
 271   ))
 272
 273 (define-public (make-simultaneous-music elts)
 274   (let*  ((m (make-music-by-name 'SimultaneousMusic)))
 275     (ly:set-mus-property! m 'elements elts)
 276     m
 277     ))
 278
 279 (define-public (make-event-chord elts)
 280   (let*  ((m (make-music-by-name 'EventChord)))
 281     (ly:set-mus-property! m 'elements elts)
 282     m
 283     ))
 284
 285
 286 (define-public (make-nonevent-skip dur)
 287   (let*  ((m (make-music-by-name 'NonEventSkip)))
 288     (ly:set-mus-property! m 'duration dur)
 289     m
 290   ))
 291
 292 ;;;;;;;;;;;;;;;;
 293
 294 ;; mmrest
 295 (define-public (make-multi-measure-rest duration location)
 296   (let*
 297       (
 298        (start (make-music-by-name 'MultiMeasureRestEvent))
 299        (stop  (make-music-by-name 'MultiMeasureRestEvent))
 300        (skip ( make-music-by-name 'SkipEvent))
 301        (ch (make-music-by-name 'BarCheck))
 302        (ch2  (make-music-by-name 'BarCheck))
 303        (seq  (make-music-by-name 'MultiMeasureRestMusicGroup))
 304        )
 305
 306     (map (lambda (x) (ly:set-mus-property! x 'origin location))
 307          (list start stop skip ch ch2 seq))
 308     (ly:set-mus-property! start 'span-direction START)
 309     (ly:set-mus-property! stop 'span-direction STOP)
 310     (ly:set-mus-property! skip 'duration duration)
 311     (ly:set-mus-property! seq 'elements
 312      (list
 313       ch
 314       (make-event-chord (list start))
 315       (make-event-chord (list skip))
 316       (make-event-chord (list stop))
 317       ch2
 318       ))
 319
 320     seq
 321     ))
 322
 323 (define-public (glue-mm-rest-texts music)
 324   "Check if we have R1*4-\\markup { .. }, and if applicable convert to
 325 a property set for MultiMeasureRestNumber."
 326
 327   (define (script-to-mmrest-text script-music)
 328     "Extract 'direction and 'text   from SCRIPT-MUSIC, and transform into property sets."
 329
 330     (let*
 331         (
 332          (text (ly:get-mus-property script-music 'text))
 333          (dir (ly:get-mus-property script-music 'direction))
 334          (p (make-music-by-name 'MultiMeasureTextEvent))
 335          )
 336
 337       (if (ly:dir? dir)
 338           (ly:set-mus-property! p  'direction dir))
 339       (ly:set-mus-property! p 'text text)
 340       p
 341     ))
 342
 343   (if (eq? (ly:get-mus-property music 'name)  'MultiMeasureRestMusicGroup)
 344       (let*
 345           (
 346            (text? (lambda (x) (memq 'script-event (ly:get-mus-property x 'types))))
 347            (es (ly:get-mus-property  music 'elements))
 348            (texts (map script-to-mmrest-text  (filter text? es)))
 349            (others (remove text? es))
 350            )
 351         (if (pair? texts)
 352             (ly:set-mus-property!
 353              music 'elements
 354              (cons (make-event-chord texts) others)
 355             ))
 356       ))
 357   music
 358   )
 359
 360
 361 (define-public (make-property-set sym val)
 362   (let*
 363       (
 364        (m (make-music-by-name 'PropertySet))
 365        )
 366     (ly:set-mus-property! m 'symbol sym)
 367     (ly:set-mus-property! m 'value val)
 368     m
 369   ))
 370
 371
 372
 373 (define-public (make-ottava-set octavation)
 374   (let*
 375       ((m (make-music-by-name 'ApplyContext)))
 376
 377
 378   (define (ottava-modify context)
 379     "Either reset centralCPosition to the stored original, or remember
 380 old centralCPosition, add OCTAVATION to centralCPosition, and set
 381 OTTAVATION to `8va', or whatever appropriate."
 382
 383     (if (number? (ly:get-context-property  context 'centralCPosition))
 384
 385         (if (= octavation 0)
 386             (let*
 387                 ((where (ly:context-property-where-defined context 'centralCPosition))
 388                  (oc0 (ly:get-context-property context 'originalCentralCPosition)))
 389
 390               (ly:set-context-property! context 'centralCPosition oc0)
 391               (ly:unset-context-property where 'originalCentralCPosition)
 392               (ly:unset-context-property where 'ottavation))
 393
 394             (let*
 395                 ((where (ly:context-property-where-defined context 'centralCPosition))
 396                  (c0 (ly:get-context-property context 'centralCPosition))
 397                  (new-c0 (+ c0 (* -7 octavation)))
 398                  (string (cdr
 399                           (assoc octavation '((2 . "15ma")
 400                                               (1 . "8va")
 401                                               (0 . #f)
 402                                               (-1 . "8va bassa")
 403                                               (-2 . "15ma bassa"))))))
 404
 405               (ly:set-context-property! context 'centralCPosition new-c0)
 406               (ly:set-context-property! context 'originalCentralCPosition c0)
 407               (ly:set-context-property! context 'ottavation string)
 408
 409               ))))
 410
 411   (ly:set-mus-property! m 'procedure  ottava-modify)
 412   (context-spec-music m 'Staff)
 413   ))
 414
 415 (define-public (set-octavation ottavation)
 416   (ly:export (make-ottava-set ottavation)))
 417
 418 (define-public (make-time-signature-set num den . rest)
 419   " Set properties for time signature NUM/DEN.
 420 Rest can contain a list of beat groupings
 421
 422 "
 423
 424   (let*
 425       (
 426        (set1 (make-property-set 'timeSignatureFraction (cons num den) ))
 427        (beat (ly:make-moment 1 den))
 428        (len  (ly:make-moment num den))
 429        (set2 (make-property-set 'beatLength beat))
 430        (set3 (make-property-set 'measureLength len))
 431        (set4 (make-property-set 'beatGrouping (if (pair? rest)
 432                                                   (car rest)
 433                                                   '())))
 434        (basic  (list set1 set2 set3 set4)))
 435
 436     (context-spec-music
 437      (make-sequential-music basic) 'Timing)))
 438
 439 (define-public (make-mark-set label)
 440   "make the music for the \\mark command."
 441
 442   (let*
 443       ((set (if (integer? label)
 444                 (context-spec-music (make-property-set 'rehearsalMark label)
 445                                     'Score)
 446                 #f))
 447        (ev (make-music-by-name 'MarkEvent))
 448        (ch (make-event-chord (list ev)))
 449        )
 450
 451
 452     (if set
 453         (make-sequential-music (list set ch))
 454         (begin
 455           (ly:set-mus-property! ev 'label label)
 456           ch))))
 457
 458
 459
 460 (define-public (set-time-signature num den . rest)
 461   (ly:export (apply make-time-signature-set `(,num ,den . ,rest))))
 462
 463 (define-public (make-penalty-music pen)
 464  (let
 465      ((m (make-music-by-name 'BreakEvent)))
 466    (ly:set-mus-property! m 'penalty pen)
 467    m))
 468
 469 (define-public (make-articulation name)
 470   (let* (
 471          (m (make-music-by-name 'ArticulationEvent))
 472       )
 473       (ly:set-mus-property! m 'articulation-type name)
 474       m
 475   ))
 476
 477 (define-public (make-lyric-event string duration)
 478   (let* ((m (make-music-by-name 'LyricEvent)))
 479
 480     (ly:set-mus-property! m 'duration duration)
 481     (ly:set-mus-property! m 'text string)
 482     m))
 483
 484 (define-public (make-span-event type spandir)
 485   (let* (
 486          (m (make-music-by-name  type))
 487          )
 488     (ly:set-mus-property! m 'span-direction spandir)
 489     m
 490     ))
 491
 492 (define-public (set-mus-properties! m alist)
 493   "Set all of ALIST as properties of M."
 494   (if (pair? alist)
 495       (begin
 496         (ly:set-mus-property! m (caar alist) (cdar alist))
 497         (set-mus-properties! m (cdr alist)))
 498   ))
 499
 500
 501
 502 (define-public (music-separator? m)
 503   "Is M a separator?"
 504   (let* ((ts (ly:get-mus-property m 'types )))
 505     (memq 'separator ts)
 506   ))
 507
 508
 509 ;;; splitting chords into voices.
 510
 511 (define (voicify-list lst number)
 512    "Make a list of Musics.
 513
 514    voicify-list :: [ [Music ] ] -> number -> [Music]
 515    LST is a list music-lists.
 516 "
 517
 518    (if (null? lst) '()
 519        (cons (context-spec-music
 520               (make-sequential-music
 521                (list
 522                 (make-voice-props-set number)
 523                 (make-simultaneous-music (car lst))))
 524
 525               'Voice  (number->string number))
 526               (voicify-list (cdr lst) (+ number 1))
 527        ))
 528    )
 529
 530 (define (voicify-chord ch)
 531   "Split the parts of a chord into different Voices using separator"
 532    (let* ((es (ly:get-mus-property ch 'elements)))
 533
 534      (ly:set-mus-property!  ch 'elements
 535        (voicify-list (split-list es music-separator?) 0))
 536      ch
 537    ))
 538
 539 (define (voicify-music m)
 540    "Recursively split chords that are separated with \\ "
 541
 542    (if (not (ly:music? m))
 543        (begin (display m)
 544        (error "not music!"))
 545        )
 546    (let*
 547        ((es (ly:get-mus-property m 'elements))
 548         (e (ly:get-mus-property m 'element))
 549         )
 550      (if (pair? es)
 551          (ly:set-mus-property! m 'elements (map voicify-music es)))
 552      (if (ly:music? e)
 553          (ly:set-mus-property! m 'element  (voicify-music e)))
 554      (if
 555       (and (equal? (ly:music-name m) "Simultaneous_music")
 556            (reduce (lambda (x y ) (or x y)) #f (map music-separator? es)))
 557       (voicify-chord m)
 558       )
 559
 560      m
 561      ))
 562
 563 (define-public (empty-music)
 564   (ly:export (make-music-by-name 'Music))
 565   )
 566 ;;;
 567
 568 ; Make a function that checks score element for being of a specific type.
 569 (define-public (make-type-checker symbol)
 570   (lambda (elt)
 571     ;;(display  symbol)
 572     ;;(eq? #t (ly:get-grob-property elt symbol))
 573     (not (eq? #f (memq symbol (ly:get-grob-property elt 'interfaces))))))
 574
 575 (define-public ((outputproperty-compatibility func sym val) grob g-context ao-context)
 576   (if (func grob)
 577       (ly:set-grob-property! grob sym val)))
 578
 579
 580 (define-public ((set-output-property grob-name symbol val)  grob grob-c context)
 581    "Usage:
 582
 583 \\applyoutput #(set-output-property 'Clef 'extra-offset '(0 . 1))
 584
 585 "
 586
 587    (let*
 588        ((meta (ly:get-grob-property grob 'meta)))
 589
 590      (if (equal?  (cdr (assoc 'name meta)) grob-name)
 591          (ly:set-grob-property! grob symbol val)
 592          )))
 593
 594
 595 ;;
 596 (define-public (smart-bar-check n)
 597   "Make  a bar check that checks for a specific bar number.
 598 "
 599   (let*
 600       (
 601        (m (make-music-by-name 'ApplyContext))
 602        )
 603
 604     (define (checker tr)
 605       (let* ((bn (ly:get-context-property tr 'currentBarNumber)))
 606         (if (= bn  n)
 607             #t
 608             (error
 609              (format "Bar check failed, we should have reached ~a, instead at ~a\n"
 610                      n bn ))
 611             )))
 612
 613     (ly:set-mus-property! m 'procedure checker)
 614     m
 615     ))
 616
 617 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 618 ;; warn for bare chords at start.
 619
 620 (define (has-request-chord elts)
 621   (reduce (lambda (x y) (or x y)) #f (map (lambda (x) (equal? (ly:music-name x)
 622                                                            "Request_chord")) elts)
 623   ))
 624
 625 (define (ly:music-message music msg)
 626   (let*
 627       (
 628       (ip (ly:get-mus-property music 'origin))
 629       )
 630
 631     (if (ly:input-location? ip)
 632         (ly:input-message ip msg)
 633         (ly:warn msg))
 634   ))
 635
 636 (define (check-start-chords music)
 637   "Check music expression for a Simultaneous_music containing notes\n(ie. Request_chords), without context specification. Called  from parser."
 638
 639      (let*
 640        ((es (ly:get-mus-property music 'elements))
 641         (e (ly:get-mus-property music 'element))
 642         (name (ly:music-name music))
 643         )
 644
 645        (cond
 646          ((equal? name "Context_specced_music") #t)
 647          ((equal? name "Simultaneous_music")
 648
 649           (if (has-request-chord es)
 650               (ly:music-message music "Starting score with a chord.\nPlease insert an explicit \\context before chord")
 651               (map check-start-chords es)))
 652
 653          ((equal? name "Sequential_music")
 654            (if (pair? es)
 655                (check-start-chords (car es))))
 656           (else (if (ly:music? e) (check-start-chords e )))
 657
 658        ))
 659      music
 660      )
 661
 662
 663
 664 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 665 ;;
 666 ;; setting stuff for grace context.
 667 ;;
 668
 669 (define (vector-extend v x)
 670   "Make a new vector consisting of V, with X added to the end."
 671   (let*
 672       ((n (vector-length v))
 673        (nv (make-vector (+ n 1) '())))
 674
 675
 676     (vector-move-left! v 0 n nv 0)
 677     (vector-set! nv n x)
 678     nv))
 679
 680
 681 (define (vector-map f v)
 682   "Map  F over V. This function returns nothing."
 683   (do
 684       ((n (vector-length v))
 685        (i 0 (+ i 1)))
 686       ((>= i n))
 687
 688     (f (vector-ref v i))))
 689
 690 (define (vector-reverse-map f v)
 691   "Map  F over V, N to 0 order. This function returns nothing."
 692   (do
 693       ((i (- (vector-length v) 1) (- i 1)))
 694       ((< i 0))
 695
 696     (f (vector-ref v i))))
 697
 698 ;; TODO:  make a remove-grace-property too.
 699 (define-public (add-grace-property context-name grob sym val)
 700   "Set SYM=VAL for GROB in CONTEXT-NAME. "
 701   (define (set-prop context)
 702     (let*
 703         ((where (ly:context-property-where-defined context 'graceSettings))
 704          (current (ly:get-context-property where 'graceSettings))
 705          (new-settings (vector-extend current (list context-name grob sym val)))
 706          )
 707       (ly:set-context-property! where 'graceSettings new-settings)))
 708
 709     (ly:export (context-spec-music (make-apply-context set-prop) 'Voice)))
 710
 711
 712 (define-public (set-start-grace-properties context)
 713   (define (execute-1 x)
 714     (let*
 715         ((tr (ly:translator-find context (car x))))
 716
 717       (if (ly:context? tr)
 718           (ly:context-pushpop-property tr (cadr x) (caddr x) (cadddr x))
 719           )))
 720
 721   (let*
 722       ((props (ly:get-context-property context 'graceSettings)))
 723     (if (vector? props)
 724         (vector-map execute-1 props))))
 725
 726 (define-public (set-stop-grace-properties context)
 727   (define (execute-1 x)
 728     (let*
 729         ((tr (ly:translator-find context (car x))))
 730       (if (ly:context? tr)
 731           (ly:context-pushpop-property tr (cadr x) (caddr x))
 732           )))
 733
 734   (let*
 735       ((props (ly:get-context-property context 'graceSettings)))
 736     (if (vector? props)
 737         (vector-reverse-map execute-1 props))))
 738
 739 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 740 ;; switch it on here, so parsing and init isn't checked (too slow!)
 741 ;;
 742 ;; automatic music transformations.
 743
 744 (define (switch-on-debugging m)
 745   (set-debug-cell-accesses! 15000)
 746   m)
 747
 748 (define-public toplevel-music-functions
 749   (list
 750 ;;   check-start-chords ; ; no longer needed with chord syntax.
 751         voicify-music
 752         (lambda (x) (music-map glue-mm-rest-texts x))
 753 ; switch-on-debugging
 754         ))
 755
 756
 757
 758
 759 ;;;;;;;;;;;;;;;;;
 760 ;; lyrics
 761
 762 (define (apply-durations lyric-music durations)
 763   (define (apply-duration music)
 764     (if (and (not (equal? (ly:music-length music) ZERO-MOMENT))
 765              (ly:duration?  (ly:get-mus-property music 'duration)))
 766         (begin
 767           (ly:set-mus-property! music 'duration (car durations))
 768           (set! durations (cdr durations))
 769           )))
 770
 771   (music-map apply-duration lyric-music))
 772
 773
 774 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 775 ;;
 776
 777
 778 (define-public ((add-balloon-text object-name text off) grob orig-context cur-context)
 779    "Usage: see input/regression/balloon.ly "
 780   (let*
 781    ((meta (ly:get-grob-property grob 'meta))
 782     (nm (if (pair? meta) (cdr (assoc 'name meta)) "nonexistant"))
 783     (cb (ly:get-grob-property grob 'molecule-callback)))
 784
 785    (if (equal? nm object-name)
 786     (begin
 787      (ly:set-grob-property! grob 'molecule-callback Balloon_interface::brew_molecule)
 788      (ly:set-grob-property! grob 'balloon-original-callback cb)
 789      (ly:set-grob-property! grob 'balloon-text text)
 790      (ly:set-grob-property! grob 'balloon-text-offset off)
 791      (ly:set-grob-property! grob 'balloon-text-props '((font-family . roman)))
 792
 793      ))))
 794
 795
 796 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 797 ;; part-combiner.
 798
 799
 800
 801 (define noticed '())
 802 (define part-combine-listener '())
 803 (define-public (set-part-combine-listener x)
 804   (set! part-combine-listener x))
 805
 806 (define-public (notice-the-events-for-pc context lst)
 807   (set! noticed (cons lst noticed)))
 808
 809 (define-public (make-new-part-combine-music music-list)
 810   (let*
 811      ((m (make-music-by-name 'NewPartCombineMusic))
 812       (m1 (context-spec-music (car music-list) 'Voice "one"))
 813       (m2 (context-spec-music (cadr music-list) 'Voice "two"))
 814       (props '((denies Thread)
 815                (consists Rest_engraver)
 816                (consists Note_heads_engraver)
 817                ))
 818       )
 819
 820
 821     (ly:set-mus-property! m 'elements (list m1 m2))
 822     (ly:set-mus-property! m1 'property-operations props)
 823     (ly:set-mus-property! m2 'property-operations props)
 824     (ly:run-translator m2 part-combine-listener)
 825     (ly:run-translator m1 part-combine-listener)
 826     (ly:set-mus-property! m 'split-list
 827                          (determine-split-list (reverse (car noticed)) (reverse (cadr noticed))))
 828     (set! noticed '())
 829
 830     m))
 831
 832 (define-public (determine-split-list evl1 evl2)
 833   "EVL1 and EVL2 should be ascending"
 834
 835   (define ev1 (list->vector evl1))
 836   (define ev2 (list->vector evl2))
 837   (define (when v i)
 838     (car (vector-ref v i)))
 839   (define (what v i)
 840     (cdr (vector-ref v i)))
 841
 842   (define chord-threshold 8)
 843
 844   (define result
 845     (list->vector
 846      (map (lambda (x)
 847             (cons x 'together))
 848           (uniq-list
 849           (merge (map car evl1) (map car evl2) ly:moment<?)))))
 850
 851   (define (analyse-events i1 i2 ri
 852                           active1
 853                           active2)
 854
 855     (define (analyse-span-event active ev)
 856       (let*
 857           ((name (ly:get-mus-property ev 'name))
 858            (key (cond
 859                  ((equal? name 'SlurEvent) 'slur)
 860                  ((equal? name 'TieEvent) 'tie)
 861                  ((equal? name 'Beam) 'beam)
 862                  (else #f)))
 863            (sp (ly:get-mus-property ev 'span-direction)))
 864
 865         (if (and (symbol? key) (ly:dir? sp))
 866             ((if (= sp STOP) delete! cons) key active))
 867         ))
 868
 869     (define (get-note-evs v i)
 870       (define (f? x)
 871         (equal? (ly:get-mus-property  x 'name) 'NoteEvent))
 872       (filter f? (map car (what v i))))
 873
 874     (define (put x)
 875       (set-cdr! (vector-ref result ri) x) )
 876
 877     (cond
 878      ((= ri (vector-length result)) '())
 879      ((= i1 (vector-length ev1)) (put 'apart))
 880      ((= i2 (vector-length ev2)) (put 'apart))
 881      (else
 882       (let*
 883           ((m1 (when ev1 i1))
 884            (m2 (when ev2 i2)))
 885
 886         (if (not (or (equal? m1 (when result ri))
 887                      (equal? m2 (when result ri))))
 888             (begin
 889               (display
 890                (list "<? M1,M2 != result :"
 891                      m1 m2 (when result ri)))
 892               (scm-error "boem")))
 893
 894         (set! active1
 895               (sort
 896                (map (lambda (x) (analyse-span-event active1  (car x)))
 897                     (what ev1 i1)) symbol<?))
 898         (set! active2
 899               (sort (map (lambda (x) (analyse-span-event active2 (car x)))
 900                          (what ev2 i2)) symbol<?))
 901
 902         (cond
 903          ((ly:moment<? m1 m2)
 904           (put 'apart)
 905           (analyse-events (1+ i1) i2 (1+ ri) active1 active2))
 906          ((ly:moment<? m2 m1)
 907           (put 'apart)
 908           (analyse-events i1 (1+ i2) (1+ ri) active1 active2))
 909          (else
 910           (if (not (equal? active1 active2))
 911               (put 'apart)
 912
 913               (let*
 914                   ((notes1 (get-note-evs ev1 i1))
 915                    (pitches1 (sort
 916                               (map (lambda (x) (ly:get-mus-property x 'pitch)) notes1) ly:pitch<?))
 917                    (notes2 (get-note-evs ev2 i2))
 918                    (pitches2 (sort
 919                               (map (lambda (x) (ly:get-mus-property x 'pitch)) notes2) ly:pitch<?))
 920                    )
 921                 (cond
 922                  ((equal? pitches1 pitches2) (put 'unisono))
 923                  ((> (length notes1) 1) (put 'apart))
 924                  ((> (length notes2) 1) (put 'apart))
 925                  (else
 926                   (let* ((diff (ly:pitch-diff (car pitches1) (car pitches1))))
 927                     (if (< (ly:pitch-steps diff) chord-threshold)
 928                         (put 'chords)
 929                         (put 'apart))
 930                     ))))
 931               )
 932           (analyse-events (1+ i1) (1+ i2) (1+ ri) active1 active2))
 933          )))))
 934
 935
 936    (analyse-events 0 0  0 '() '())
 937    (display result)
 938    (vector->list result))
 939
 940
 941
 942 ; (determine-split-list '((1 . 2) (3 . 4)) '((1 . 2) (3 . 4)))