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        (ch (make-music-by-name 'BarCheck))
 300        (ch2  (make-music-by-name 'BarCheck))
 301        (seq (make-music-by-name 'MultiMeasureRestMusicGroup))
 302        )
 303
 304     (map (lambda (x) (ly:set-mus-property! x 'origin location))
 305          (list start ch ch2 seq))
 306     (ly:set-mus-property! start 'duration duration)
 307     (ly:set-mus-property! seq 'elements
 308      (list
 309       ch
 310       (make-event-chord (list start))
 311       ch2
 312       ))
 313
 314     seq
 315     ))
 316
 317 (define-public (glue-mm-rest-texts music)
 318   "Check if we have R1*4-\\markup { .. }, and if applicable convert to
 319 a property set for MultiMeasureRestNumber."
 320
 321   (define (script-to-mmrest-text script-music)
 322     "Extract 'direction and 'text   from SCRIPT-MUSIC, and transform into property sets."
 323
 324     (let*
 325         (
 326          (text (ly:get-mus-property script-music 'text))
 327          (dir (ly:get-mus-property script-music 'direction))
 328          (p (make-music-by-name 'MultiMeasureTextEvent))
 329          )
 330
 331       (if (ly:dir? dir)
 332           (ly:set-mus-property! p  'direction dir))
 333       (ly:set-mus-property! p 'text text)
 334       p
 335     ))
 336
 337   (if (eq? (ly:get-mus-property music 'name)  'MultiMeasureRestMusicGroup)
 338       (let*
 339           (
 340            (text? (lambda (x) (memq 'script-event (ly:get-mus-property x 'types))))
 341            (es (ly:get-mus-property  music 'elements))
 342            (texts (map script-to-mmrest-text  (filter text? es)))
 343            (others (remove text? es))
 344            )
 345         (if (pair? texts)
 346             (ly:set-mus-property!
 347              music 'elements
 348              (cons (make-event-chord texts) others)
 349             ))
 350       ))
 351   music
 352   )
 353
 354
 355 (define-public (make-property-set sym val)
 356   (let*
 357       (
 358        (m (make-music-by-name 'PropertySet))
 359        )
 360     (ly:set-mus-property! m 'symbol sym)
 361     (ly:set-mus-property! m 'value val)
 362     m
 363   ))
 364
 365
 366
 367 (define-public (make-ottava-set octavation)
 368   (let*
 369       ((m (make-music-by-name 'ApplyContext)))
 370
 371
 372   (define (ottava-modify context)
 373     "Either reset centralCPosition to the stored original, or remember
 374 old centralCPosition, add OCTAVATION to centralCPosition, and set
 375 OTTAVATION to `8va', or whatever appropriate."
 376
 377     (if (number? (ly:get-context-property  context 'centralCPosition))
 378
 379         (if (= octavation 0)
 380             (let*
 381                 ((where (ly:context-property-where-defined context 'centralCPosition))
 382                  (oc0 (ly:get-context-property context 'originalCentralCPosition)))
 383
 384               (ly:set-context-property! context 'centralCPosition oc0)
 385               (ly:unset-context-property where 'originalCentralCPosition)
 386               (ly:unset-context-property where 'ottavation))
 387
 388             (let*
 389                 ((where (ly:context-property-where-defined context 'centralCPosition))
 390                  (c0 (ly:get-context-property context 'centralCPosition))
 391                  (new-c0 (+ c0 (* -7 octavation)))
 392                  (string (cdr
 393                           (assoc octavation '((2 . "15ma")
 394                                               (1 . "8va")
 395                                               (0 . #f)
 396                                               (-1 . "8va bassa")
 397                                               (-2 . "15ma bassa"))))))
 398
 399               (ly:set-context-property! context 'centralCPosition new-c0)
 400               (ly:set-context-property! context 'originalCentralCPosition c0)
 401               (ly:set-context-property! context 'ottavation string)
 402
 403               ))))
 404
 405   (ly:set-mus-property! m 'procedure  ottava-modify)
 406   (context-spec-music m 'Staff)
 407   ))
 408
 409 (define-public (set-octavation ottavation)
 410   (ly:export (make-ottava-set ottavation)))
 411
 412 (define-public (make-time-signature-set num den . rest)
 413   " Set properties for time signature NUM/DEN.
 414 Rest can contain a list of beat groupings
 415
 416 "
 417
 418   (let*
 419       (
 420        (set1 (make-property-set 'timeSignatureFraction (cons num den) ))
 421        (beat (ly:make-moment 1 den))
 422        (len  (ly:make-moment num den))
 423        (set2 (make-property-set 'beatLength beat))
 424        (set3 (make-property-set 'measureLength len))
 425        (set4 (make-property-set 'beatGrouping (if (pair? rest)
 426                                                   (car rest)
 427                                                   '())))
 428        (basic  (list set1 set2 set3 set4)))
 429
 430     (context-spec-music
 431      (make-sequential-music basic) 'Timing)))
 432
 433 (define-public (make-mark-set label)
 434   "make the music for the \\mark command."
 435
 436   (let*
 437       ((set (if (integer? label)
 438                 (context-spec-music (make-property-set 'rehearsalMark label)
 439                                     'Score)
 440                 #f))
 441        (ev (make-music-by-name 'MarkEvent))
 442        (ch (make-event-chord (list ev)))
 443        )
 444
 445
 446     (if set
 447         (make-sequential-music (list set ch))
 448         (begin
 449           (ly:set-mus-property! ev 'label label)
 450           ch))))
 451
 452
 453
 454 (define-public (set-time-signature num den . rest)
 455   (ly:export (apply make-time-signature-set `(,num ,den . ,rest))))
 456
 457 (define-public (make-penalty-music pen)
 458  (let
 459      ((m (make-music-by-name 'BreakEvent)))
 460    (ly:set-mus-property! m 'penalty pen)
 461    m))
 462
 463 (define-public (make-articulation name)
 464   (let* (
 465          (m (make-music-by-name 'ArticulationEvent))
 466       )
 467       (ly:set-mus-property! m 'articulation-type name)
 468       m
 469   ))
 470
 471 (define-public (make-lyric-event string duration)
 472   (let* ((m (make-music-by-name 'LyricEvent)))
 473
 474     (ly:set-mus-property! m 'duration duration)
 475     (ly:set-mus-property! m 'text string)
 476     m))
 477
 478 (define-public (make-span-event type spandir)
 479   (let* (
 480          (m (make-music-by-name  type))
 481          )
 482     (ly:set-mus-property! m 'span-direction spandir)
 483     m
 484     ))
 485
 486 (define-public (set-mus-properties! m alist)
 487   "Set all of ALIST as properties of M."
 488   (if (pair? alist)
 489       (begin
 490         (ly:set-mus-property! m (caar alist) (cdar alist))
 491         (set-mus-properties! m (cdr alist)))
 492   ))
 493
 494
 495
 496 (define-public (music-separator? m)
 497   "Is M a separator?"
 498   (let* ((ts (ly:get-mus-property m 'types )))
 499     (memq 'separator ts)
 500   ))
 501
 502
 503 ;;; splitting chords into voices.
 504
 505 (define (voicify-list lst number)
 506    "Make a list of Musics.
 507
 508    voicify-list :: [ [Music ] ] -> number -> [Music]
 509    LST is a list music-lists.
 510 "
 511
 512    (if (null? lst) '()
 513        (cons (context-spec-music
 514               (make-sequential-music
 515                (list
 516                 (make-voice-props-set number)
 517                 (make-simultaneous-music (car lst))))
 518
 519               'Voice  (number->string number))
 520               (voicify-list (cdr lst) (+ number 1))
 521        ))
 522    )
 523
 524 (define (voicify-chord ch)
 525   "Split the parts of a chord into different Voices using separator"
 526    (let* ((es (ly:get-mus-property ch 'elements)))
 527
 528      (ly:set-mus-property!  ch 'elements
 529        (voicify-list (split-list es music-separator?) 0))
 530      ch
 531    ))
 532
 533 (define (voicify-music m)
 534    "Recursively split chords that are separated with \\ "
 535
 536    (if (not (ly:music? m))
 537        (begin (display m)
 538        (error "not music!"))
 539        )
 540    (let*
 541        ((es (ly:get-mus-property m 'elements))
 542         (e (ly:get-mus-property m 'element))
 543         )
 544      (if (pair? es)
 545          (ly:set-mus-property! m 'elements (map voicify-music es)))
 546      (if (ly:music? e)
 547          (ly:set-mus-property! m 'element  (voicify-music e)))
 548      (if
 549       (and (equal? (ly:music-name m) "Simultaneous_music")
 550            (reduce (lambda (x y ) (or x y)) #f (map music-separator? es)))
 551       (voicify-chord m)
 552       )
 553
 554      m
 555      ))
 556
 557 (define-public (empty-music)
 558   (ly:export (make-music-by-name 'Music))
 559   )
 560 ;;;
 561
 562 ; Make a function that checks score element for being of a specific type.
 563 (define-public (make-type-checker symbol)
 564   (lambda (elt)
 565     ;;(display  symbol)
 566     ;;(eq? #t (ly:get-grob-property elt symbol))
 567     (not (eq? #f (memq symbol (ly:get-grob-property elt 'interfaces))))))
 568
 569 (define-public ((outputproperty-compatibility func sym val) grob g-context ao-context)
 570   (if (func grob)
 571       (ly:set-grob-property! grob sym val)))
 572
 573
 574 (define-public ((set-output-property grob-name symbol val)  grob grob-c context)
 575    "Usage:
 576
 577 \\applyoutput #(set-output-property 'Clef 'extra-offset '(0 . 1))
 578
 579 "
 580
 581    (let*
 582        ((meta (ly:get-grob-property grob 'meta)))
 583
 584      (if (equal?  (cdr (assoc 'name meta)) grob-name)
 585          (ly:set-grob-property! grob symbol val)
 586          )))
 587
 588
 589 ;;
 590 (define-public (smart-bar-check n)
 591   "Make  a bar check that checks for a specific bar number.
 592 "
 593   (let*
 594       (
 595        (m (make-music-by-name 'ApplyContext))
 596        )
 597
 598     (define (checker tr)
 599       (let* ((bn (ly:get-context-property tr 'currentBarNumber)))
 600         (if (= bn  n)
 601             #t
 602             (error
 603              (format "Bar check failed, we should have reached ~a, instead at ~a\n"
 604                      n bn ))
 605             )))
 606
 607     (ly:set-mus-property! m 'procedure checker)
 608     m
 609     ))
 610
 611 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 612 ;; warn for bare chords at start.
 613
 614 (define (has-request-chord elts)
 615   (reduce (lambda (x y) (or x y)) #f (map (lambda (x) (equal? (ly:music-name x)
 616                                                            "Request_chord")) elts)
 617   ))
 618
 619 (define (ly:music-message music msg)
 620   (let*
 621       (
 622       (ip (ly:get-mus-property music 'origin))
 623       )
 624
 625     (if (ly:input-location? ip)
 626         (ly:input-message ip msg)
 627         (ly:warn msg))
 628   ))
 629
 630 (define (check-start-chords music)
 631   "Check music expression for a Simultaneous_music containing notes\n(ie. Request_chords), without context specification. Called  from parser."
 632
 633      (let*
 634        ((es (ly:get-mus-property music 'elements))
 635         (e (ly:get-mus-property music 'element))
 636         (name (ly:music-name music))
 637         )
 638
 639        (cond
 640          ((equal? name "Context_specced_music") #t)
 641          ((equal? name "Simultaneous_music")
 642
 643           (if (has-request-chord es)
 644               (ly:music-message music "Starting score with a chord.\nPlease insert an explicit \\context before chord")
 645               (map check-start-chords es)))
 646
 647          ((equal? name "Sequential_music")
 648            (if (pair? es)
 649                (check-start-chords (car es))))
 650           (else (if (ly:music? e) (check-start-chords e )))
 651
 652        ))
 653      music
 654      )
 655
 656
 657
 658 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 659 ;;
 660 ;; setting stuff for grace context.
 661 ;;
 662
 663 (define (vector-extend v x)
 664   "Make a new vector consisting of V, with X added to the end."
 665   (let*
 666       ((n (vector-length v))
 667        (nv (make-vector (+ n 1) '())))
 668
 669
 670     (vector-move-left! v 0 n nv 0)
 671     (vector-set! nv n x)
 672     nv))
 673
 674
 675 (define (vector-map f v)
 676   "Map  F over V. This function returns nothing."
 677   (do
 678       ((n (vector-length v))
 679        (i 0 (+ i 1)))
 680       ((>= i n))
 681
 682     (f (vector-ref v i))))
 683
 684 (define (vector-reverse-map f v)
 685   "Map  F over V, N to 0 order. This function returns nothing."
 686   (do
 687       ((i (- (vector-length v) 1) (- i 1)))
 688       ((< i 0))
 689
 690     (f (vector-ref v i))))
 691
 692 ;; TODO:  make a remove-grace-property too.
 693 (define-public (add-grace-property context-name grob sym val)
 694   "Set SYM=VAL for GROB in CONTEXT-NAME. "
 695   (define (set-prop context)
 696     (let*
 697         ((where (ly:context-property-where-defined context 'graceSettings))
 698          (current (ly:get-context-property where 'graceSettings))
 699          (new-settings (vector-extend current (list context-name grob sym val)))
 700          )
 701       (ly:set-context-property! where 'graceSettings new-settings)))
 702
 703     (ly:export (context-spec-music (make-apply-context set-prop) 'Voice)))
 704
 705
 706 (define-public (set-start-grace-properties context)
 707   (define (execute-1 x)
 708     (let*
 709         ((tr (ly:translator-find context (car x))))
 710
 711       (if (ly:context? tr)
 712           (ly:context-pushpop-property tr (cadr x) (caddr x) (cadddr x))
 713           )))
 714
 715   (let*
 716       ((props (ly:get-context-property context 'graceSettings)))
 717     (if (vector? props)
 718         (vector-map execute-1 props))))
 719
 720 (define-public (set-stop-grace-properties context)
 721   (define (execute-1 x)
 722     (let*
 723         ((tr (ly:translator-find context (car x))))
 724       (if (ly:context? tr)
 725           (ly:context-pushpop-property tr (cadr x) (caddr x))
 726           )))
 727
 728   (let*
 729       ((props (ly:get-context-property context 'graceSettings)))
 730     (if (vector? props)
 731         (vector-reverse-map execute-1 props))))
 732
 733 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 734 ;; switch it on here, so parsing and init isn't checked (too slow!)
 735 ;;
 736 ;; automatic music transformations.
 737
 738 (define (switch-on-debugging m)
 739   (set-debug-cell-accesses! 15000)
 740   m)
 741
 742 (define-public toplevel-music-functions
 743   (list
 744 ;;   check-start-chords ; ; no longer needed with chord syntax.
 745         voicify-music
 746         (lambda (x) (music-map glue-mm-rest-texts x))
 747 ; switch-on-debugging
 748         ))
 749
 750
 751
 752
 753 ;;;;;;;;;;;;;;;;;
 754 ;; lyrics
 755
 756 (define (apply-durations lyric-music durations)
 757   (define (apply-duration music)
 758     (if (and (not (equal? (ly:music-length music) ZERO-MOMENT))
 759              (ly:duration?  (ly:get-mus-property music 'duration)))
 760         (begin
 761           (ly:set-mus-property! music 'duration (car durations))
 762           (set! durations (cdr durations))
 763           )))
 764
 765   (music-map apply-duration lyric-music))
 766
 767
 768 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 769 ;;
 770
 771
 772 (define-public ((add-balloon-text object-name text off) grob orig-context cur-context)
 773    "Usage: see input/regression/balloon.ly "
 774   (let*
 775    ((meta (ly:get-grob-property grob 'meta))
 776     (nm (if (pair? meta) (cdr (assoc 'name meta)) "nonexistant"))
 777     (cb (ly:get-grob-property grob 'molecule-callback)))
 778
 779    (if (equal? nm object-name)
 780     (begin
 781      (ly:set-grob-property! grob 'molecule-callback Balloon_interface::brew_molecule)
 782      (ly:set-grob-property! grob 'balloon-original-callback cb)
 783      (ly:set-grob-property! grob 'balloon-text text)
 784      (ly:set-grob-property! grob 'balloon-text-offset off)
 785      (ly:set-grob-property! grob 'balloon-text-props '((font-family . roman)))
 786
 787      ))))
 788
 789
 790 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 791 ;; part-combiner.
 792
 793
 794
 795 (define noticed '())
 796 (define part-combine-listener '())
 797 (define-public (set-part-combine-listener x)
 798   (set! part-combine-listener x))
 799
 800 (define-public (notice-the-events-for-pc context lst)
 801   (set! noticed (acons (ly:context-id context) lst noticed)))
 802
 803 (define-public (make-new-part-combine-music music-list)
 804   (let*
 805      ((m (make-music-by-name 'NewPartCombineMusic))
 806       (m1 (context-spec-music (car music-list) 'Voice "one"))
 807       (m2 (context-spec-music (cadr music-list) 'Voice "two"))
 808       (props '((denies Thread)
 809                (consists Rest_engraver)
 810                (consists Note_heads_engraver)
 811                )))
 812
 813     (ly:set-mus-property! m 'elements (list m1 m2))
 814     (ly:set-mus-property! m1 'property-operations props)
 815     (ly:set-mus-property! m2 'property-operations props)
 816     (ly:run-translator m2 part-combine-listener)
 817     (ly:run-translator m1 part-combine-listener)
 818     (ly:set-mus-property! m 'split-list
 819                          (determine-split-list (reverse (cdr (assoc "one" noticed)))
 820                                                (reverse (cdr (assoc "two" noticed)))))
 821     (set! noticed '())
 822
 823     m))
 824
 825
 826
 827 ;;
 828 ;; todo: this function is rather too hairy and too long.
 829 ;;
 830 (define-public (determine-split-list evl1 evl2)
 831   "EVL1 and EVL2 should be ascending"
 832   (define pc-debug #t)
 833   (define ev1 (list->vector evl1))
 834   (define ev2 (list->vector evl2))
 835   (define (when v i)
 836     (car (vector-ref v i)))
 837   (define (what v i)
 838     (cdr (vector-ref v i)))
 839
 840   (define chord-threshold 8)
 841   (define (get-note-evs v i)
 842     (define (f? x)
 843       (equal? (ly:get-mus-property  x 'name) 'NoteEvent))
 844     (filter f? (map car (what v i))))
 845   (define moments (uniq-list
 846                    (merge (map car evl1) (map car evl2) ly:moment<?)))
 847   (define result '())
 848
 849   (define (analyse-time-step i1 i2 ri
 850                              active1
 851                              active2)
 852
 853     (define (analyse-tie-start active ev)
 854       (if (equal? (ly:get-mus-property ev 'name) 'TieEvent)
 855           (acons 'tie ri active)
 856           active
 857           ))
 858
 859     (define (analyse-tie-end active ev)
 860       (if (equal? (ly:get-mus-property ev 'name) 'NoteEvent)
 861           (assoc-remove!  active 'tie)
 862           active) )
 863
 864     (define (active<? a b)
 865       (cond
 866        ((symbol<? (car a) (car b)) #t)
 867        ((symbol<? (car b) (car b)) #f)
 868        (else
 869         (< (cdr a) (cdr b)))
 870        ))
 871
 872     (define (analyse-span-event active ev)
 873       (let*
 874           ((name (ly:get-mus-property ev 'name))
 875            (key (cond
 876                        ((equal? name 'SlurEvent) 'slur)
 877                        ((equal? name 'PhrasingSlurEvent) 'tie)
 878                        ((equal? name 'BeamEvent) 'beam)
 879                        ((equal? name 'CrescendoEvent) 'cresc)
 880                        ((equal? name 'DecrescendoEvent) 'decr)
 881                        (else #f)) )
 882            (sp (ly:get-mus-property ev 'span-direction))
 883            )
 884
 885         (if (and (symbol? key) (ly:dir? sp))
 886             (if (= sp STOP)
 887                 (assoc-remove! active key)
 888                 (acons key ri active))
 889             active)
 890         ))
 891
 892     (define (analyse-events active evs)
 893       (define (helper analyzer active evs)
 894         (if (pair? evs)
 895             (helper analyzer (analyzer active (car evs)) (cdr evs))
 896             active
 897             ))
 898       (sort
 899        (helper analyse-span-event
 900                (helper analyse-tie-start
 901                        (helper analyse-tie-end active evs) evs) evs)
 902        active<?))
 903
 904
 905     (define (put x . index)
 906       "Put the result to X, starting from INDEX backwards."
 907       (let
 908           ((i (if (pair? index) (car index) ri)))
 909
 910         (if (and (<= 0 i) (not (symbol? (what result i))))
 911             (begin
 912               (set-cdr! (vector-ref result i) x)
 913               (put x (1- i))
 914             ))
 915         ))
 916
 917
 918     (cond
 919      ((= ri (vector-length result)) '())
 920      ((= i1 (vector-length ev1)) (put 'apart))
 921      ((= i2 (vector-length ev2)) (put 'apart))
 922      (else
 923       (let*
 924           ((now (when result ri))
 925 ;          (x (display (list "\nelse" (= i1 (vector-length ev1)) i2  (vector-length ev2) (= i2 (vector-length ev2)))))
 926            (m1 (when ev1 i1))
 927            (m2 (when ev2 i2))
 928 ;          (x (display "oked"))
 929            (evs1 (map car (what ev1 i1)))
 930            (evs2 (map car (what ev2 i2)))
 931            (new-active1 (analyse-events active1 evs1))
 932            (new-active2 (analyse-events active2 evs2))
 933            )
 934
 935
 936         (or #t (display (list (when result ri) i1 i2 ri
 937                        active1 "->" new-active1
 938                        active2 "->" new-active2
 939                        (vector-length ev1) (vector-length ev2) (vector-length result)  "\n")))
 940
 941
 942         (if (not (or (equal? m1 now)
 943                      (equal? m2 now)))
 944             (begin
 945               (display
 946                (list "<? M1,M2 != result :"
 947                      m1 m2 (when result ri)))
 948               (scm-error "boem")))
 949
 950         (cond
 951          ((ly:moment<? m1 m2)
 952           (put 'apart)
 953           (if (> ri 0) (put 'apart (1- ri)))
 954           (analyse-time-step (1+ i1) i2 (1+ ri) new-active1 active2))
 955          ((ly:moment<? m2 m1)
 956           (put 'apart)
 957           (if (> ri 0) (put 'apart (1- ri)))
 958           (analyse-time-step i1 (1+ i2) (1+ ri) active1 new-active2))
 959          (else
 960
 961           (if (and (equal? active1 active2) (equal? new-active2 new-active1))
 962               (let*
 963                   ((notes1 (get-note-evs ev1 i1))
 964                    (durs1     (sort (map (lambda (x) (ly:get-mus-property x 'duration)) notes1) ly:duration<?))
 965                    (pitches1 (sort
 966                               (map (lambda (x) (ly:get-mus-property x 'pitch)) notes1) ly:pitch<?))
 967                    (notes2 (get-note-evs ev2 i2))
 968                    (durs2     (sort (map (lambda (x) (ly:get-mus-property x 'duration)) notes2) ly:duration<?))
 969                    (pitches2 (sort
 970                               (map (lambda (x) (ly:get-mus-property x 'pitch)) notes2) ly:pitch<?))
 971                    )
 972                 (cond
 973                  ((> (length notes1) 1) (put 'apart))
 974                  ((> (length notes2) 1) (put 'apart))
 975                  ((not (= (length notes1) (length notes2)))
 976                   (put 'apart))
 977                  ((and
 978                    (= (length durs1) 1)
 979                    (= (length durs2) 1)
 980                    (not (equal? (car durs1) (car durs2))))
 981
 982                   (put 'apart))
 983                  (else
 984                   (if (and (= (length pitches1) (length pitches2)))
 985                       (if
 986                        (and (pair?  pitches1) (pair? pitches2)
 987                        (< chord-threshold (ly:pitch-steps
 988                                            (ly:pitch-diff (car pitches1) (car pitches2)))))
 989                        (put 'apart)
 990
 991
 992                        ;; copy previous split state from spanner state
 993                        (begin
 994                          (map (lambda (key-idx)
 995                                 (let*
 996                                     ((idx (cdr key-idx))
 997                                      (prev (what result  idx))
 998                                      )
 999                                   (if (symbol? prev)
1000                                       (put prev))
1001                                   )) (append active1 active2))
1002                          (if (and (null? new-active1) (null? new-active2))
1003                              (put 'chords ri))))
1004
1005                   ))))
1006
1007               ;; active states different:
1008               ;; must mark differently so
1009               ;; it doesn't transform into solo
1010               (put 'apart-spanner))
1011           (analyse-time-step (1+ i1) (1+ i2) (1+ ri) new-active1 new-active2)))
1012          ))))
1013
1014 ;;
1015    (define (analyse-solo12 i1 i2 ri)
1016      (define (put x)
1017        (set-cdr! (vector-ref result ri) x) )
1018      (cond
1019       ((= ri (vector-length result)) '())
1020       ((= i1 (vector-length ev1)) '())
1021       ((= i2 (vector-length ev2)) '())
1022       (else
1023        (let*
1024           ((now (when result ri))
1025            (m1 (when ev1 i1))
1026            (m2 (when ev2 i2))
1027            (notes1 (get-note-evs ev1
1028                                  (if (ly:moment<?  now m1)
1029                                      (1- i1) i1)))
1030
1031            (durs1 (sort (map (lambda (x) (ly:get-mus-property x 'duration)) notes1) ly:duration<?))
1032            (pitches1 (sort
1033                       (map (lambda (x) (ly:get-mus-property x 'pitch)) notes1) ly:pitch<?))
1034
1035            (notes2 (get-note-evs ev2
1036                                  (if (ly:moment<? now m2)
1037                                      (1- i2) i2)))
1038            (n2 (length notes2))
1039            (n1 (length notes1))
1040            (durs2 (sort (map (lambda (x) (ly:get-mus-property x 'duration)) notes2) ly:duration<?))
1041            (pitches2 (sort
1042                       (map (lambda (x) (ly:get-mus-property x 'pitch)) notes2) ly:pitch<?))
1043            )
1044
1045         (if pc-debug (display (list
1046                          "\n"
1047                          (when result ri) i1 "/" (vector-length ev1)
1048                               m1 ":" notes1
1049                               i2 "/" (vector-length ev2) m2 ":"
1050                               notes2
1051                               ri "/" (vector-length result)  " = "
1052                               (what  result ri)
1053                               "\n"
1054                               )))
1055
1056
1057
1058          (if (equal? (what result ri) 'apart)
1059              (cond
1060               ((and (= 0 n1)
1061                     (< 0 n2)
1062                     (equal? now m2)
1063                     )
1064                (put 'solo2))
1065               ((and (< 0 n1)
1066                     (= 0 n2)
1067                     (equal? now m1)
1068                     )
1069                (put 'solo1))
1070               ((and (= 0 n1)
1071                     (= 0 n2))
1072                (put 'apart-silence))
1073               ))
1074
1075          (if (and
1076               (equal? (what result ri) 'chords)
1077               (equal? pitches1 pitches2))
1078              (put (if (pair? pitches2)
1079                       'unisono 'unisilence) ))
1080
1081          (cond
1082           ((ly:moment<? m1 m2)
1083            (analyse-solo12 (1+ i1) i2 (1+ ri) ))
1084           ((ly:moment<? m2 m1)
1085            (analyse-solo12 i1 (1+ i2) (1+ ri) ))
1086           (else
1087            (analyse-solo12 (1+ i1) (1+ i2) (1+ ri)))
1088           )))))
1089    (set! result (list->vector
1090                  (map (lambda (x)
1091                         (cons x '())) moments)))
1092
1093    (analyse-time-step 0 0  0 '() '())
1094    (if pc-debug (display result))
1095    (analyse-solo12 0 0 0)
1096    (if pc-debug (display result))
1097
1098    (vector->list result))