scm/music-functions.scm

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; tuplets.
   3
   4 (define-public (denominator-tuplet-formatter mus)
   5   (number->string (ly:get-mus-property mus 'denominator)))
   6
   7 (define-public (fraction-tuplet-formatter mus)
   8   (string-append (number->string (ly:get-mus-property mus 'numerator))
   9                  ":"
  10                  (number->string (ly:get-mus-property mus 'denominator))
  11                  ))
  12
  13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14
  15 (define-public (music-map function music)
  16   "Apply @var{function} to @var{music} and all of the music it contains. "
  17   (let* ((es (ly:get-mus-property music 'elements))
  18          (e (ly:get-mus-property music 'element))
  19          )
  20
  21     (ly:set-mus-property! music 'elements
  22         (map (lambda (y) (music-map  function y)) es))
  23         (if (ly:music? e)
  24             (ly:set-mus-property! music 'element (music-map function  e)))
  25         (function music)
  26         ))
  27
  28 (define-public (display-one-music music)
  29   (display music)
  30   (display (ly:get-mutable-properties music))
  31   music
  32   )
  33
  34 (define-public (display-music arg)
  35   (music-map display-one-music arg))
  36
  37 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38
  39 (define (shift-one-duration-log music shift dot)
  40   "  add SHIFT to ly:duration-log and optionally
  41   a dot to any note encountered. This scales the music up by a factor
  42   2^shift * (2 - (1/2)^dot)"
  43
  44   (let*
  45       (
  46        (d (ly:get-mus-property music 'duration))
  47        )
  48     (if (ly:duration? d)
  49         (let* (
  50                (cp (ly:duration-factor d))
  51                (nd (ly:make-duration (+ shift (ly:duration-log d))
  52                                      (+ dot (ly:duration-dot-count d))
  53                                      (car cp)
  54                                      (cdr cp)))
  55
  56                )
  57           (ly:set-mus-property! music 'duration nd)
  58           ))
  59     music))
  60
  61
  62
  63 (define-public (shift-duration-log music shift dot)
  64   (music-map (lambda (x) (shift-one-duration-log x shift dot))
  65              music))
  66
  67
  68 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  69 ;; repeats.
  70
  71 (define-public (unfold-repeats music)
  72 "
  73 This function replaces all repeats  with unfold repeats. It was
  74 written by Rune Zedeler. "
  75   (let* ((es (ly:get-mus-property music 'elements))
  76          (e (ly:get-mus-property music 'element))
  77          (n  (ly:music-name music)))
  78
  79     (if (equal? n "Repeated_music")
  80         (begin
  81           (if (equal?
  82                (ly:get-mus-property music 'iterator-ctor)
  83                Chord_tremolo_iterator::constructor)
  84               (shift-duration-log music  (ly:intlog2 (ly:get-mus-property music 'repeat-count)) 0)
  85               )
  86           (ly:set-mus-property!
  87            music 'length Repeated_music::unfolded_music_length)
  88           (ly:set-mus-property!
  89            music 'start-moment-function Repeated_music::first_start)
  90           (ly:set-mus-property!
  91            music 'iterator-ctor Unfolded_repeat_iterator::constructor)))
  92
  93     (if (pair? es)
  94         (ly:set-mus-property!
  95          music 'elements
  96          (map unfold-repeats es)))
  97
  98     (if (ly:music? e)
  99         (ly:set-mus-property!
 100          music 'element
 101          (unfold-repeats e)))
 102
 103     music))
 104
 105
 106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 107 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 108
 109 (define  (pitchify-scripts music)
 110   "Copy the pitch fields of the Note_requests into  Text_script_requests, to aid
 111 Fingering_engraver."
 112   (define (find-note musics)
 113     (filter-list (lambda (m) (equal? (ly:music-name m) "Note_req")) musics)
 114     )
 115   (define (find-scripts musics)
 116     (filter-list (lambda (m) (equal? (ly:music-name m) "Text_script_req")) musics))
 117
 118   (let* (
 119          (e (ly:get-mus-property music 'element))
 120          (es (ly:get-mus-property music 'elements))
 121          (notes (find-note es))
 122          (pitch (if (pair? notes) (ly:get-mus-property (car  notes) 'pitch) #f))
 123          )
 124
 125     (if pitch
 126         (map (lambda (x) (ly:set-mus-property! x 'pitch pitch)) (find-scripts es))
 127         )
 128
 129     (if (pair? es)
 130         (ly:set-mus-property!
 131          music 'elements
 132          (map pitchify-scripts es)))
 133
 134     (if (ly:music? e)
 135         (ly:set-mus-property!
 136          music 'element
 137          (pitchify-scripts e)))
 138
 139     music))
 140
 141
 142 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 143 ;; property setting music objs.
 144 (define-public (make-grob-property-set grob gprop val)
 145   "Make a M-exp that sets GPROP to VAL in GROBS. Does a pop first, i.e.
 146 this is not an override
 147 "
 148
 149    (let* ((m (make-music-by-name  'OverrideProperty)))
 150      (ly:set-mus-property! m 'symbol grob)
 151      (ly:set-mus-property! m 'grob-property gprop)
 152      (ly:set-mus-property! m 'grob-value val)
 153      (ly:set-mus-property! m 'pop-first #t)
 154
 155      m
 156
 157    ))
 158
 159
 160 (define-public (make-grob-property-revert grob gprop)
 161   "Revert the grob property GPROP for GROB."
 162    (let* ((m (make-music-by-name  'OverrideProperty)))
 163      (ly:set-mus-property! m 'symbol grob)
 164      (ly:set-mus-property! m 'grob-property gprop)
 165
 166      m
 167
 168    ))
 169
 170 (define-public (make-voice-props-set n)
 171   (make-sequential-music
 172    (append
 173       (map (lambda (x) (make-grob-property-set x 'direction
 174                                                (if (odd? n) -1 1)))
 175            '(Tie Slur Stem Dots))
 176       (list
 177        (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2))
 178        (make-grob-property-set 'MultiMeasureRest 'staff-position
 179                                (if (odd? n) -4 4)
 180                                )
 181
 182        )
 183    )
 184   ))
 185
 186 (define-public (make-voice-props-revert)
 187   (make-sequential-music
 188    (list
 189       (make-grob-property-revert 'Tie 'direction)
 190       (make-grob-property-revert 'Dots 'direction)
 191       (make-grob-property-revert 'Stem 'direction)
 192       (make-grob-property-revert 'Slur 'direction)
 193       (make-grob-property-revert 'NoteColumn 'horizontal-shift)
 194    ))
 195   )
 196
 197 (define-public (context-spec-music m context . rest)
 198   "Add \context CONTEXT = foo to M. "
 199
 200   (let* ((cm (make-music-by-name 'ContextSpeccedMusic)))
 201     (ly:set-mus-property! cm 'element m)
 202     (ly:set-mus-property! cm 'context-type context)
 203     (if (and  (pair? rest) (string? (car rest)))
 204         (ly:set-mus-property! cm 'context-id (car rest))
 205     )
 206     cm
 207   ))
 208
 209 (define-public (make-sequential-music elts)
 210   (let*  ((m (make-music-by-name 'SequentialMusic)))
 211     (ly:set-mus-property! m 'elements elts)
 212     m
 213   ))
 214
 215 (define-public (make-simultaneous-music elts)
 216   (let*  ((m (make-music-by-name 'SimultaneousMusic)))
 217     (ly:set-mus-property! m 'elements elts)
 218     m
 219     ))
 220
 221 (define-public (make-event-chord elts)
 222   (let*  ((m (make-music-by-name 'EventChord)))
 223     (ly:set-mus-property! m 'elements elts)
 224     m
 225     ))
 226
 227
 228 (define-public (make-multi-measure-rest duration location)
 229   (let*
 230       (
 231        (start (make-music-by-name 'MultiMeasureRestEvent))
 232        (stop  (make-music-by-name 'MultiMeasureRestEvent))
 233        (skip ( make-music-by-name 'SkipEvent))
 234        (ch (make-music-by-name 'BarCheck))
 235        (ch2  (make-music-by-name 'BarCheck))
 236        )
 237
 238     (ly:set-mus-property! start 'span-direction START)
 239     (ly:set-mus-property! stop 'span-direction STOP)
 240     (ly:set-mus-property! skip 'duration duration)
 241     (map (lambda (x) (ly:set-mus-property! x 'origin location))
 242          (list start stop skip ch ch2))
 243     (make-sequential-music
 244      (list
 245       ch
 246       (make-event-chord (list start))
 247       (make-event-chord (list skip))
 248       (make-event-chord (list stop))
 249       ch2
 250       ))
 251     ))
 252
 253
 254 (define-public (make-property-set sym val)
 255   (let*
 256       (
 257        (m (make-music-by-name 'PropertySet))
 258        )
 259     (ly:set-mus-property! m 'symbol sym)
 260     (ly:set-mus-property! m 'value val)
 261     m
 262   ))
 263
 264 (define-public (make-time-signature-set num den . rest)
 265   " Set properties for time signature NUM/DEN.
 266 Rest can contain a list of beat groupings
 267
 268 "
 269
 270   (let*
 271       (
 272        (set1 (make-property-set 'timeSignatureFraction (cons num den) ))
 273        (beat (ly:make-moment 1 den))
 274        (len  (ly:make-moment num den))
 275        (set2 (make-property-set 'beatLength beat))
 276        (set3 (make-property-set 'measureLength len))
 277        (set4 (make-property-set 'beatGrouping (if (pair? rest)
 278                                                   (car rest)
 279                                                   '())))
 280        (basic  (list set1 set2 set3 set4))
 281
 282        )
 283
 284     (context-spec-music
 285      (make-sequential-music basic) "Timing")))
 286
 287 (define-public (set-time-signature num den . rest)
 288   (ly:export (apply make-time-signature-set `(,num ,den . ,rest)))
 289   )
 290
 291 (define-public (make-penalty-music pen)
 292  (let
 293      ((m (make-music-by-name 'BreakEvent)))
 294    (ly:set-mus-property! m 'penalty pen)
 295    m))
 296
 297 (define-public (make-articulation name)
 298   (let* (
 299          (m (make-music-by-name 'ArticulationEvent))
 300       )
 301       (ly:set-mus-property! m 'articulation-type name)
 302       m
 303   ))
 304
 305 (define-public (make-span-event type spandir)
 306   (let* (
 307          (m (make-music-by-name  type))
 308          )
 309     (ly:set-mus-property! m 'span-direction spandir)
 310     m
 311     ))
 312
 313 (define-public (set-mus-properties! m alist)
 314   "Set all of ALIST as properties of M."
 315   (if (pair? alist)
 316       (begin
 317         (ly:set-mus-property! m (caar alist) (cdar alist))
 318         (set-mus-properties! m (cdr alist)))
 319   ))
 320
 321 (define-public (music-separator? m)
 322   "Is M a separator?"
 323   (let* ((ts (ly:get-mus-property m 'types )))
 324     (memq 'separator ts)
 325   ))
 326
 327 (define (split-one sep?  l acc)
 328   "Split off the first parts before separator and return both parts.
 329
 330 "
 331   (if (null? l)
 332       (cons acc '())
 333       (if (sep? (car l))
 334           (cons acc (cdr l))
 335           (split-one sep? (cdr l) (cons (car l) acc))
 336           )
 337       ))
 338
 339 (define-public (split-list l sep?)
 340   "
 341
 342 (display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) )
 343 =>
 344  ...
 345
 346 "
 347   (if (null? l)
 348       '()
 349       (let* ((c (split-one sep? l '())))
 350         (cons (reverse! (car c) '()) (split-list (cdr c) sep?))
 351         )
 352       )
 353   )
 354
 355 ;;; splitting chords into voices.
 356
 357 (define (voicify-list lst number)
 358    "Make a list of Musics.
 359
 360    voicify-list :: [ [Music ] ] -> number -> [Music]
 361    LST is a list music-lists.
 362 "
 363
 364    (if (null? lst) '()
 365        (cons (context-spec-music
 366               (make-sequential-music
 367                (list
 368                 (make-voice-props-set number)
 369                 (make-simultaneous-music (car lst))))
 370
 371               "Voice"  (number->string number))
 372               (voicify-list (cdr lst) (+ number 1))
 373        ))
 374    )
 375
 376 (define (voicify-chord ch)
 377   "Split the parts of a chord into different Voices using separator"
 378    (let* ((es (ly:get-mus-property ch 'elements)))
 379
 380
 381      (ly:set-mus-property!  ch 'elements
 382        (voicify-list (split-list es music-separator?) 0))
 383      ch
 384    ))
 385
 386 (define (voicify-music m)
 387    "Recursively split chords that are separated with \\ "
 388
 389    (if (not (ly:music? m))
 390        (begin (display m)
 391        (error "not music!"))
 392        )
 393    (let*
 394        ((es (ly:get-mus-property m 'elements))
 395         (e (ly:get-mus-property m 'element))
 396         )
 397      (if (pair? es)
 398          (ly:set-mus-property! m 'elements (map voicify-music es)))
 399      (if (ly:music? e)
 400          (ly:set-mus-property! m 'element  (voicify-music e)))
 401      (if
 402       (and (equal? (ly:music-name m) "Simultaneous_music")
 403            (reduce (lambda (x y ) (or x y))     (map music-separator? es)))
 404       (voicify-chord m)
 405       )
 406
 407      m
 408      ))
 409
 410 (define-public (empty-music)
 411   (ly:export (make-music-by-name 'Music))
 412   )
 413 ;;;
 414
 415 ; Make a function that checks score element for being of a specific type.
 416 (define-public (make-type-checker symbol)
 417   (lambda (elt)
 418     ;;(display  symbol)
 419     ;;(eq? #t (ly:get-grob-property elt symbol))
 420     (not (eq? #f (memq symbol (ly:get-grob-property elt 'interfaces))))))
 421
 422
 423 ;;
 424 (define-public (smart-bar-check n)
 425   "Make  a bar check that checks for a specific bar number.
 426 "
 427   (let*
 428       (
 429        (m (make-music-by-name 'ApplyContext))
 430        )
 431
 432     (define (checker tr)
 433       (let* ((bn (ly:get-context-property tr 'currentBarNumber)))
 434         (if (= bn  n)
 435             #t
 436             (error
 437              (format "Bar check failed, we should have reached ~a, instead at ~a\n"
 438                      n bn ))
 439             )))
 440
 441     (ly:set-mus-property! m 'procedure checker)
 442     m
 443     ))
 444
 445 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 446 ;; warn for bare chords at start.
 447
 448 (define (has-request-chord elts)
 449   (reduce (lambda (x y) (or x y)) (map (lambda (x) (equal? (ly:music-name x)
 450                                                            "Request_chord")) elts)
 451   ))
 452
 453 (define (ly:music-message music msg)
 454   (let* (
 455       (ip (ly:get-mus-property music 'origin))
 456       )
 457
 458     (if (ly:input-location? ip)
 459         (ly:input-message ip msg)
 460         (ly:warn msg))
 461   ))
 462
 463 (define (check-start-chords music)
 464   "Check music expression for a Simultaneous_music containing notes\n(ie. Request_chords), without context specification. Called  from parser."
 465
 466      (let*
 467        ((es (ly:get-mus-property music 'elements))
 468         (e (ly:get-mus-property music 'element))
 469         (name (ly:music-name music))
 470         )
 471
 472        (cond
 473          ((equal? name "Context_specced_music") #t)
 474          ((equal? name "Simultaneous_music")
 475
 476           (if (has-request-chord es)
 477               (ly:music-message music "Starting score with a chord.\nPlease insert an explicit \\context before chord")
 478               (map check-start-chords es)))
 479
 480          ((equal? name "Sequential_music")
 481            (if (pair? es)
 482                (check-start-chords (car es))))
 483           (else (if (ly:music? e) (check-start-chords e )))
 484
 485        ))
 486      music
 487      )
 488
 489
 490 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 491 ;; switch it on here, so parsing and init isn't checked (too slow!)
 492
 493 ;; automatic music transformations.
 494
 495 (define (switch-on-debugging m)
 496   (set-debug-cell-accesses! 15000)
 497   m
 498   )
 499
 500 (define-public toplevel-music-functions
 501   (list check-start-chords
 502         voicify-music
 503
 504 ; switch-on-debugging
 505         ))
 506
 507