ly/music-functions-init.ly

   1 % -*-Scheme-*-
   2
   3 \version "2.7.39"
   4
   5 %% need SRFI-1 filter
   6
   7 #(use-modules (srfi srfi-1))
   8
   9
  10 tweak = #(define-music-function (parser location sym val arg)
  11            (symbol? scheme? ly:music?)
  12
  13            "Add @code{sym . val} to the @code{tweaks} property of @var{arg}."
  14
  15
  16            (set!
  17             (ly:music-property arg 'tweaks)
  18             (acons sym val
  19                    (ly:music-property arg 'tweaks)))
  20            arg)
  21
  22 tag = #(define-music-function (parser location tag arg)
  23    (symbol? ly:music?)
  24
  25    "Add @var{tag} to the @code{tags} property of @var{arg}."
  26
  27    (set!
  28     (ly:music-property arg 'tags)
  29     (cons tag
  30           (ly:music-property arg 'tags)))
  31    arg)
  32
  33 clef =
  34 #(define-music-function (parser location type)
  35    (string?)
  36
  37    "Set the current clef."
  38
  39    (make-clef-set type))
  40
  41 bar =
  42 #(define-music-function (parser location type)
  43    (string?)
  44    (context-spec-music
  45     (make-property-set 'whichBar type)
  46     'Timing))
  47
  48 applyMusic =
  49 #(define-music-function (parser location func music) (procedure? ly:music?)
  50                (func music))
  51
  52 oldaddlyrics =
  53 #(define-music-function (parser location music lyrics) (ly:music? ly:music?)
  54
  55               (make-music 'OldLyricCombineMusic
  56                           'origin location
  57                           'elements (list music lyrics)))
  58
  59 grace =
  60 #(def-grace-function startGraceMusic stopGraceMusic)
  61
  62 acciaccatura =
  63 #(def-grace-function startAcciaccaturaMusic stopAcciaccaturaMusic)
  64 appoggiatura =
  65 #(def-grace-function startAppoggiaturaMusic stopAppoggiaturaMusic)
  66
  67 partcombine =
  68 #(define-music-function (parser location part1 part2) (ly:music? ly:music?)
  69                 (make-part-combine-music (list part1 part2)))
  70
  71 autochange =
  72 #(define-music-function (parser location music) (ly:music?)
  73                (make-autochange-music music))
  74
  75 applyContext =
  76 #(define-music-function (parser location proc) (procedure?)
  77                  (make-music 'ApplyContext
  78                    'origin location
  79                    'procedure proc))
  80
  81 shiftDurations =
  82 #(define-music-function (parser location dur dots arg) (integer? integer? ly:music?)
  83    ""
  84
  85
  86    (music-map
  87     (lambda (x)
  88       (shift-one-duration-log x dur dots)) arg))
  89
  90 musicMap =
  91 #(define-music-function (parser location proc mus) (procedure? ly:music?)
  92              (music-map proc mus))
  93
  94 displayMusic =
  95 #(define-music-function (parser location music) (ly:music?)
  96                  (display-scheme-music music)
  97                  music)
  98
  99 %% FIXME: guile-1.7 required?
 100 %#(use-modules (scm display-lily))invalid module name for use-syntax ((srfi srfi-39))
 101
 102 #(use-modules (scm display-lily))
 103 #(display-lily-init parser)
 104 displayLilyMusic =
 105 #(define-music-function (parser location music) (ly:music?)
 106    (display-lily-music music)
 107    music)
 108
 109 applyOutput =
 110 #(define-music-function (parser location ctx proc) (symbol? procedure?)
 111                 (make-music 'ApplyOutputEvent
 112                   'origin location
 113                   'procedure proc
 114                   'context-type ctx))
 115
 116 overrideProperty =
 117 #(define-music-function (parser location name property value)
 118    (string? symbol? scheme?)
 119
 120
 121    "Set @var{property} to @var{value} in all grobs named @var{name}.
 122 The @var{name} argument is a string of the form @code{\"Context.GrobName\"}
 123 or @code{\"GrobName\"}"
 124
 125    (let*
 126        ((name-components (string-split name #\.))
 127         (context-name 'Bottom)
 128         (grob-name #f))
 129
 130      (if (> 2 (length name-components))
 131          (set! grob-name (string->symbol (car name-components)))
 132          (begin
 133            (set! grob-name (string->symbol (list-ref name-components 1)))
 134            (set! context-name (string->symbol (list-ref name-components 0)))))
 135
 136      (context-spec-music
 137       (make-music 'ApplyOutputEvent
 138                   'origin location
 139                   'procedure
 140                   (lambda (grob orig-context context)
 141                     (if (equal?
 142                          (cdr (assoc 'name (ly:grob-property grob 'meta)))
 143                          grob-name)
 144                         (set! (ly:grob-property grob property) value))))
 145
 146       context-name)))
 147
 148 breathe =
 149 #(define-music-function (parser location) ()
 150             (make-music 'EventChord
 151               'origin location
 152               'elements (list (make-music 'BreathingSignEvent))))
 153
 154
 155 unfoldRepeats =
 156 #(define-music-function (parser location music) (ly:music?)
 157                   (unfold-repeats music))
 158
 159 compressMusic =
 160 #(define-music-function
 161                   (parser location fraction music) (number-pair? ly:music?)
 162                   (ly:music-compress music (ly:make-moment (car fraction) (cdr fraction))))
 163
 164 makeClusters =
 165 #(define-music-function
 166                 (parser location arg) (ly:music?)
 167                 (music-map note-to-cluster arg))
 168
 169
 170 removeWithTag =
 171 #(define-music-function
 172   (parser location tag music) (symbol? ly:music?)
 173   (music-filter
 174    (lambda (m)
 175     (let* ((tags (ly:music-property m 'tags))
 176            (res (memq tag tags)))
 177      (not res)))
 178  music))
 179
 180 keepWithTag =
 181 #(define-music-function
 182   (parser location tag music) (symbol? ly:music?)
 183   (music-filter
 184    (lambda (m)
 185     (let* ((tags (ly:music-property m 'tags))
 186            (res (memq tag tags)))
 187      (or
 188       (eq? tags '())
 189       res)))
 190    music))
 191
 192
 193 %% Todo:
 194 %% doing
 195 %% define-music-function in a .scm causes crash.
 196
 197 cueDuring =
 198 #(define-music-function
 199   (parser location what dir main-music)
 200   (string? ly:dir? ly:music?)
 201   (make-music 'QuoteMusic
 202               'element main-music
 203               'quoted-context-type 'Voice
 204               'quoted-context-id "cue"
 205               'quoted-music-name what
 206               'quoted-voice-direction dir
 207               'origin location))
 208
 209
 210 transposedCueDuring = #
 211 (define-music-function
 212   (parser location what dir pitch-note main-music)
 213   (string? ly:dir? ly:music? ly:music?)
 214
 215   "Insert notes from the part @var{what} into a voice called @code{cue},
 216 using the transposition defined by @var{pitch-note}.  This happens
 217 simultaneously with @var{main-music}, which is usually a rest.  The
 218 argument @var{dir} determines whether the cue notes should be notated
 219 as a first or second voice."
 220
 221   (make-music 'QuoteMusic
 222               'element main-music
 223               'quoted-context-type 'Voice
 224               'quoted-context-id "cue"
 225               'quoted-music-name what
 226               'quoted-voice-direction dir
 227               'quoted-transposition (pitch-of-note pitch-note)
 228               'origin location))
 229
 230
 231 quoteDuring = #
 232 (define-music-function
 233   (parser location what main-music)
 234   (string? ly:music?)
 235   (make-music 'QuoteMusic
 236               'element main-music
 237               'quoted-music-name what
 238               'origin location))
 239
 240
 241 pitchedTrill =
 242 #(define-music-function
 243    (parser location main-note secondary-note)
 244    (ly:music? ly:music?)
 245    (let*
 246        ((get-notes (lambda (ev-chord)
 247                      (filter
 248                       (lambda (m) (eq? 'NoteEvent (ly:music-property m 'name)))
 249                       (ly:music-property ev-chord 'elements))))
 250         (sec-note-events (get-notes secondary-note))
 251         (trill-events (filter (lambda (m) (memq 'trill-span-event (ly:music-property m 'types)))
 252                               (ly:music-property main-note 'elements)))
 253
 254         (trill-pitch
 255          (if (pair? sec-note-events)
 256              (ly:music-property (car sec-note-events) 'pitch)
 257              )))
 258
 259      (if (ly:pitch? trill-pitch)
 260          (for-each (lambda (m) (ly:music-set-property! m 'pitch trill-pitch))
 261                    trill-events)
 262          (begin
 263            (ly:warning (_ "Second argument of \\pitchedTrill should be single note: "))
 264            (display sec-note-events)))
 265
 266      main-note))
 267
 268 killCues =
 269 #(define-music-function
 270    (parser location music)
 271    (ly:music?)
 272    (music-map
 273     (lambda (mus)
 274       (if (string? (ly:music-property mus 'quoted-music-name))
 275           (ly:music-property mus 'element)
 276           mus)) music))
 277
 278
 279 afterGraceFraction =
 280 #(cons 6 8)
 281
 282 afterGrace =
 283 #(define-music-function
 284   (parser location main grace)
 285   (ly:music? ly:music?)
 286
 287   (let*
 288       ((main-length (ly:music-length main))
 289        (fraction  (ly:parser-lookup parser 'afterGraceFraction)))
 290
 291     (make-simultaneous-music
 292      (list
 293       main
 294       (make-sequential-music
 295        (list
 296
 297         (make-music 'SkipMusic
 298                     'duration (ly:make-duration
 299                                0 0
 300                                (* (ly:moment-main-numerator main-length)
 301                                   (car fraction))
 302                                (* (ly:moment-main-denominator main-length)
 303                                   (cdr fraction)) ))
 304         (make-music 'GraceMusic
 305                     'element grace)))))))
 306
 307
 308 barNumberCheck =
 309 #(define-music-function (parser location n) (integer?)
 310    (make-music 'ApplyContext
 311                'origin location
 312                'procedure
 313                (lambda (c)
 314                  (let*
 315                      ((cbn (ly:context-property c 'currentBarNumber)))
 316                    (if (not (= cbn n))
 317                        (ly:input-message location "Barcheck failed got ~a expect ~a"
 318                                          cbn n))))))
 319
 320
 321
 322 % for regression testing purposes.
 323 assertBeamQuant =
 324 #(define-music-function (parser location l r) (pair? pair?)
 325   (make-grob-property-override 'Beam 'positions
 326    (ly:make-simple-closure
 327     (ly:make-simple-closure
 328      (append
 329       (list chain-grob-member-functions `(,cons 0 0))
 330       (check-quant-callbacks l r))))))
 331
 332 % for regression testing purposes.
 333 assertBeamSlope =
 334 #(define-music-function (parser location comp) (procedure?)
 335   (make-grob-property-override 'Beam 'positions
 336    (ly:make-simple-closure
 337     (ly:make-simple-closure
 338      (append
 339       (list chain-grob-member-functions `(,cons 0 0))
 340       (check-slope-callbacks comp))))))
 341
 342
 343 parallelMusic =
 344 #(define-music-function (parser location voice-ids music) (list? ly:music?)
 345   "Define parallel music sequences, separated by '|' (bar check signs),
 346 and assign them to the identifiers provided in @var{voice-ids}.
 347
 348 @var{voice-ids}: a list of music identifiers (symbols containing only letters)
 349
 350 @var{music}: a music sequence, containing BarChecks as limiting expressions.
 351
 352 Example:
 353   \\parallelMusic #'(A B C) {
 354     c c | d d | e e |
 355     d d | e e | f f |
 356   }
 357 <==>
 358   A = { c c | d d | }
 359   B = { d d | e e | }
 360   C = { e e | f f | }
 361 "
 362   (let* ((voices (apply circular-list (make-list (length voice-ids) (list))))
 363          (current-voices voices)
 364          (current-sequence (list)))
 365     ;;
 366     ;; utilities
 367     (define (push-music m)
 368       "Push the music expression into the current sequence"
 369       (set! current-sequence (cons m current-sequence)))
 370     (define (change-voice)
 371       "Stores the previously built sequence into the current voice and
 372        change to the following voice."
 373       (list-set! current-voices 0 (cons (make-music 'SequentialMusic
 374                                          'elements (reverse! current-sequence))
 375                                         (car current-voices)))
 376       (set! current-sequence (list))
 377       (set! current-voices (cdr current-voices)))
 378     (define (bar-check? m)
 379       "Checks whether m is a bar check."
 380       (eq? (ly:music-property m 'name) 'BarCheck))
 381     (define (music-origin music)
 382       "Recursively search an origin location stored in music."
 383       (cond ((null? music) #f)
 384             ((not (null? (ly:music-property music 'origin)))
 385              (ly:music-property music 'origin))
 386             (else (or (music-origin (ly:music-property music 'element))
 387                       (let ((origins (remove not (map music-origin
 388                                                       (ly:music-property music 'elements)))))
 389                         (and (not (null? origins)) (car origins)))))))
 390     ;;
 391     ;; first, split the music and fill in voices
 392     (map-in-order (lambda (m)
 393                     (push-music m)
 394                     (if (bar-check? m) (change-voice)))
 395                   (ly:music-property music 'elements))
 396     (if (not (null? current-sequence)) (change-voice))
 397     ;; un-circularize `voices' and reorder the voices
 398     (set! voices (map-in-order (lambda (dummy seqs)
 399                                  (reverse! seqs))
 400                                voice-ids voices))
 401     ;;
 402     ;; set origin location of each sequence in each voice
 403     ;; for better type error tracking
 404     (for-each (lambda (voice)
 405                 (for-each (lambda (seq)
 406                             (set! (ly:music-property seq 'origin)
 407                                   (or (music-origin seq) location)))
 408                           voice))
 409               voices)
 410     ;;
 411     ;; check sequence length
 412     (apply for-each (lambda (. seqs)
 413                       (let ((moment-reference (ly:music-length (car seqs))))
 414                         (for-each (lambda (seq moment)
 415                                     (if (not (equal? moment moment-reference))
 416                                         (ly:music-message seq
 417                                          "Bars in parallel music don't have the same length")))
 418                           seqs (map-in-order ly:music-length seqs))))
 419            voices)
 420    ;;
 421    ;; bind voice identifiers to the voices
 422    (map (lambda (voice-id voice)
 423           (ly:parser-define! parser voice-id
 424                              (make-music 'SequentialMusic
 425                                'origin location
 426                                'elements voice)))
 427         voice-ids voices))
 428  ;; Return an empty sequence. this function is actually a "void" function.
 429  (make-music 'SequentialMusic 'void #t))
 430
 431
 432
 433
 434 %% this is a stub. Write your own to suit the spacing tweak output.
 435 spacingTweaks =
 436 #(define-music-function (parser location parameters) (list?)
 437    (make-music 'SequentialMusic 'void #t))
 438
 439 octave =
 440 #(define-music-function (parser location pitch-note) (ly:music?)
 441    "octave check"
 442
 443    (make-music 'RelativeOctaveCheck
 444                'origin location
 445                'pitch (pitch-of-note pitch-note)
 446                ))
 447
 448 addquote =
 449 #(define-music-function (parser location name music) (string? ly:music?)
 450    "Add a piece of music to be quoted "
 451    (add-quotable name music)
 452    (make-music 'SequentialMusic 'void #t))
 453
 454
 455 parenthesize =
 456 #(define-music-function (parser loc arg) (ly:music?)
 457    "Tag @var{arg} to be parenthesized."
 458
 459    (set! (ly:music-property arg 'parenthesize) #t)
 460    arg)
 461
 462
 463 featherDurations=
 464 #(define-music-function (parser location factor argument) (ly:moment? ly:music?)
 465
 466    "Rearrange durations in ARGUMENT so there is an
 467 acceleration/deceleration. "
 468
 469    (let*
 470        ((orig-duration (ly:music-length argument))
 471         (multiplier (ly:make-moment 1 1)))
 472
 473      (music-map
 474       (lambda (mus)
 475         (if (and (eq? (ly:music-property mus 'name) 'EventChord)
 476                  (< 0 (ly:moment-main-denominator (ly:music-length mus))))
 477             (begin
 478               (ly:music-compress mus multiplier)
 479               (set! multiplier (ly:moment-mul factor multiplier)))
 480             )
 481         mus)
 482       argument)
 483
 484      (ly:music-compress
 485       argument
 486       (ly:moment-div orig-duration (ly:music-length argument)))
 487
 488      argument))
 489