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