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 ;; due to a bug in the GUILE evaluator,
 829 ;; stack traces result in core dumps.
 830 ;; therefore we retain debugging code.
 831 ;;
 832
 833 ;;
 834 ;; todo: this is too hairy.
 835 ;;
 836 (define-public (determine-split-list evl1 evl2)
 837   "EVL1 and EVL2 should be ascending"
 838
 839   (define ev1 (list->vector evl1))
 840   (define ev2 (list->vector evl2))
 841   (define (when v i)
 842     (car (vector-ref v i)))
 843   (define (what v i)
 844     (cdr (vector-ref v i)))
 845
 846   (define chord-threshold 8)
 847
 848   (define result
 849     (list->vector
 850      (map (lambda (x)
 851             (cons x '()))
 852           (uniq-list
 853           (merge (map car evl1) (map car evl2) ly:moment<?)))))
 854
 855   (define (analyse-time-step i1 i2 ri
 856                              active1
 857                              active2)
 858
 859     (define (analyse-tie-start active ev)
 860       (if (equal? (ly:get-mus-property ev 'name) 'TieEvent)
 861           (acons 'tie ri active)
 862           active
 863           ))
 864
 865     (define (analyse-tie-end active ev)
 866       (if (equal? (ly:get-mus-property ev 'name) 'NoteEvent)
 867           (assoc-remove!  active 'tie)
 868           active) )
 869     (define (active<? a b)
 870       (cond
 871        ((symbol<? (car a) (car b)) #t)
 872        ((symbol<? (car b) (car b)) #f)
 873        (else
 874         (< (cdr a) (cdr b)))
 875        ))
 876
 877     (define (analyse-span-event active ev)
 878       (let*
 879           ((name (ly:get-mus-property ev 'name))
 880            (key (cond
 881                        ((equal? name 'SlurEvent) 'slur)
 882                        ((equal? name 'PhrasingSlurEvent) 'tie)
 883                        ((equal? name 'BeamEvent) 'beam)
 884                        ((equal? name 'CrescendoEvent) 'cresc)
 885                        ((equal? name 'DecrescendoEvent) 'decr)
 886                        (else #f)) )
 887            (sp (ly:get-mus-property ev 'span-direction))
 888            )
 889
 890         (if (and (symbol? key) (ly:dir? sp))
 891             (if (= sp STOP)
 892                 (assoc-remove! active key)
 893                 (acons key ri active))
 894             active)
 895         ))
 896
 897     (define (analyse-events active evs)
 898       (define (helper analyzer active evs)
 899         (if (pair? evs)
 900             (helper analyzer (analyzer active (car evs)) (cdr evs))
 901             active
 902             ))
 903       (sort
 904        (helper analyse-span-event
 905                (helper analyse-tie-start
 906                        (helper analyse-tie-end active evs) evs) evs)
 907        active<?))
 908
 909     (define (get-note-evs v i)
 910       (define (f? x)
 911         (equal? (ly:get-mus-property  x 'name) 'NoteEvent))
 912       (filter f? (map car (what v i))))
 913
 914     (define (put x . index)
 915       "Put the result to X, starting from INDEX backwards."
 916       (let
 917           ((i (if (pair? index) (car index) ri)))
 918
 919         (if (and (<= 0 i) (not (symbol? (what result i))))
 920             (begin
 921               (set-cdr! (vector-ref result i) x)
 922               (put x (1- i))
 923             ))
 924         ))
 925
 926
 927 ;    (display (list i1 i2 ri active1 active2 (vector-length ev1) (vector-length ev2) (vector-length result)  "\n"))
 928     (cond
 929      ((= ri (vector-length result)) '())
 930      ((= i1 (vector-length ev1)) (put 'apart))
 931      ((= i2 (vector-length ev2)) (put 'apart))
 932      (else
 933       (let*
 934           (
 935 ;          (x (display (list "\nelse" (= i1 (vector-length ev1)) i2  (vector-length ev2) (= i2 (vector-length ev2)))))
 936            (m1 (when ev1 i1))
 937            (m2 (when ev2 i2))
 938 ;          (x (display "oked"))
 939            (evs1 (map car (what ev1 i1)))
 940            (evs2 (map car (what ev2 i2)))
 941
 942            (new-active1 (analyse-events active1 evs1))
 943            (new-active2 (analyse-events active2 evs2))
 944            )
 945
 946         (if (not (or (equal? m1 (when result ri))
 947                      (equal? m2 (when result ri))))
 948             (begin
 949               (display
 950                (list "<? M1,M2 != result :"
 951                      m1 m2 (when result ri)))
 952               (scm-error "boem")))
 953
 954         (cond
 955          ((ly:moment<? m1 m2)
 956           (put 'apart)
 957           (if (> ri 0) (put 'apart (1- ri)))
 958           (analyse-time-step (1+ i1) i2 (1+ ri) new-active1 new-active2))
 959          ((ly:moment<? m2 m1)
 960           (put 'apart)
 961           (if (> ri 0) (put 'apart (1- ri)))
 962           (analyse-time-step i1 (1+ i2) (1+ ri) new-active1 new-active2))
 963          (else
 964           (if (and (equal? active1 active2) (equal? new-active2 new-active1))
 965               (let*
 966                   ((notes1 (get-note-evs ev1 i1))
 967                    (pitches1 (sort
 968                               (map (lambda (x) (ly:get-mus-property x 'pitch)) notes1) ly:pitch<?))
 969                    (notes2 (get-note-evs ev2 i2))
 970                    (pitches2 (sort
 971                               (map (lambda (x) (ly:get-mus-property x 'pitch)) notes2) ly:pitch<?))
 972                    )
 973                 (cond
 974                  ((> (length notes1) 1) (put 'apart))
 975                  ((> (length notes2) 1) (put 'apart))
 976                  (else
 977                   (if
 978                    (and (= (length pitches1) 1) (= (length pitches2) 1)
 979                     (< chord-threshold (ly:pitch-steps
 980                                         (ly:pitch-diff (car pitches1) (car pitches2)))))
 981                         (put 'apart)
 982
 983
 984                         ;; copy previous split state from spanner state
 985                         (begin
 986                           (map (lambda (key-idx)
 987                                  (let*
 988                                      ((idx (cdr key-idx))
 989                                       (prev (what result  idx))
 990                                       )
 991                                    (if (symbol? prev)
 992                                        (put prev))
 993                                    )) (append active1 active2))
 994                           (if (and (null? new-active1) (null? new-active2))
 995                               (put 'chords ri)))
 996
 997                     ))) )
 998               ;; active states different:
 999               (put 'apart) )
1000           (analyse-time-step (1+ i1) (1+ i2) (1+ ri) new-active1 new-active2))
1001          )))))
1002
1003 ;;
1004
1005
1006
1007    (analyse-time-step 0 0  0 '() '())
1008 ;   (display result)
1009    (vector->list result))