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