ly/music-functions-init.ly

   1 % -*-Scheme-*-
   2
   3 \version "2.7.32"
   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    (music-map
  84     (lambda (x)
  85       (shift-one-duration-log x dur dots)) arg))
  86
  87 musicMap =
  88 #(define-music-function (parser location proc mus) (procedure? ly:music?)
  89              (music-map proc mus))
  90
  91 displayMusic =
  92 #(define-music-function (parser location music) (ly:music?)
  93                  (display-scheme-music music)
  94                  music)
  95
  96 %% FIXME: guile-1.7 required?
  97 %#(use-modules (scm display-lily))invalid module name for use-syntax ((srfi srfi-39))
  98
  99 #(use-modules (scm display-lily))
 100 #(display-lily-init parser)
 101 displayLilyMusic =
 102 #(define-music-function (parser location music) (ly:music?)
 103    (display-lily-music music)
 104    music)
 105
 106 applyOutput =
 107 #(define-music-function (parser location proc) (procedure?)
 108                 (make-music 'ApplyOutputEvent
 109                   'origin location
 110                   'procedure proc))
 111
 112 overrideProperty =
 113 #(define-music-function (parser location name property value)
 114    (string? symbol? scheme?)
 115
 116
 117    "Set @var{property} to @var{value} in all grobs named @var{name}.
 118 The @var{name} argument is a string of the form @code{\"Context.GrobName\"}
 119 or @code{\"GrobName\"}"
 120
 121    (let*
 122        ((name-components (string-split name #\.))
 123         (context-name 'Bottom)
 124         (grob-name #f))
 125
 126      (if (> 2 (length name-components))
 127          (set! grob-name (string->symbol (car name-components)))
 128          (begin
 129            (set! grob-name (string->symbol (list-ref name-components 1)))
 130            (set! context-name (string->symbol (list-ref name-components 0)))))
 131
 132      (context-spec-music
 133       (make-music 'ApplyOutputEvent
 134                   'origin location
 135                   'procedure
 136                   (lambda (grob orig-context context)
 137                     (if (equal?
 138                          (cdr (assoc 'name (ly:grob-property grob 'meta)))
 139                          grob-name)
 140                         (set! (ly:grob-property grob property) value)
 141                         )))
 142
 143       context-name)))
 144
 145 breathe =
 146 #(define-music-function (parser location) ()
 147             (make-music 'EventChord
 148               'origin location
 149               'elements (list (make-music 'BreathingSignEvent))))
 150
 151
 152 unfoldRepeats =
 153 #(define-music-function (parser location music) (ly:music?)
 154                   (unfold-repeats music))
 155
 156 compressMusic =
 157 #(define-music-function
 158                   (parser location fraction music) (number-pair? ly:music?)
 159                   (ly:music-compress music (ly:make-moment (car fraction) (cdr fraction))))
 160
 161 makeClusters =
 162 #(define-music-function
 163                 (parser location arg) (ly:music?)
 164                 (music-map note-to-cluster arg))
 165
 166
 167 removeWithTag =
 168 #(define-music-function
 169   (parser location tag music) (symbol? ly:music?)
 170   (music-filter
 171    (lambda (m)
 172     (let* ((tags (ly:music-property m 'tags))
 173            (res (memq tag tags)))
 174      (not res)))
 175  music))
 176
 177 keepWithTag =
 178 #(define-music-function
 179   (parser location tag music) (symbol? ly:music?)
 180   (music-filter
 181    (lambda (m)
 182     (let* ((tags (ly:music-property m 'tags))
 183            (res (memq tag tags)))
 184      (or
 185       (eq? tags '())
 186       res)))
 187    music))
 188
 189
 190 %% Todo:
 191 %% doing
 192 %% define-music-function in a .scm causes crash.
 193
 194 cueDuring =
 195 #(define-music-function
 196   (parser location what dir main-music)
 197   (string? ly:dir? ly:music?)
 198   (make-music 'QuoteMusic
 199               'element main-music
 200               'quoted-context-type 'Voice
 201               'quoted-context-id "cue"
 202               'quoted-music-name what
 203               'quoted-voice-direction dir
 204               'origin location))
 205
 206
 207 quoteDuring = #
 208 (define-music-function
 209   (parser location what main-music)
 210   (string? ly:music?)
 211   (make-music 'QuoteMusic
 212               'element main-music
 213               'quoted-music-name what
 214               'origin location))
 215
 216
 217
 218 pitchedTrill =
 219 #(define-music-function
 220    (parser location main-note secondary-note)
 221    (ly:music? ly:music?)
 222    (let*
 223        ((get-notes (lambda (ev-chord)
 224                      (filter
 225                       (lambda (m) (eq? 'NoteEvent (ly:music-property m 'name)))
 226                       (ly:music-property ev-chord 'elements))))
 227         (sec-note-events (get-notes secondary-note))
 228         (trill-events (filter (lambda (m) (memq 'trill-span-event (ly:music-property m 'types)))
 229                               (ly:music-property main-note 'elements)))
 230
 231         (trill-pitch
 232          (if (pair? sec-note-events)
 233              (ly:music-property (car sec-note-events) 'pitch)
 234              )))
 235
 236      (if (ly:pitch? trill-pitch)
 237          (for-each (lambda (m) (ly:music-set-property! m 'pitch trill-pitch))
 238                    trill-events)
 239          (begin
 240            (ly:warning (_ "Second argument of \\pitchedTrill should be single note: "))
 241            (display sec-note-events)))
 242
 243      main-note))
 244
 245 killCues =
 246 #(define-music-function
 247    (parser location music)
 248    (ly:music?)
 249    (music-map
 250     (lambda (mus)
 251       (if (string? (ly:music-property mus 'quoted-music-name))
 252           (ly:music-property mus 'element)
 253           mus)) music))
 254
 255
 256 afterGraceFraction =
 257 #(cons 6 8)
 258
 259 afterGrace =
 260 #(define-music-function
 261   (parser location main grace)
 262   (ly:music? ly:music?)
 263
 264   (let*
 265       ((main-length (ly:music-length main))
 266        (fraction  (ly:parser-lookup parser 'afterGraceFraction)))
 267
 268     (make-simultaneous-music
 269      (list
 270       main
 271       (make-sequential-music
 272        (list
 273
 274         (make-music 'SkipMusic
 275                     'duration (ly:make-duration
 276                                0 0
 277                                (* (ly:moment-main-numerator main-length)
 278                                   (car fraction))
 279                                (* (ly:moment-main-denominator main-length)
 280                                   (cdr fraction)) ))
 281         (make-music 'GraceMusic
 282                     'element grace)))))))
 283
 284
 285 barNumberCheck =
 286 #(define-music-function (parser location n) (integer?)
 287    (make-music 'ApplyContext
 288                'origin location
 289                'procedure
 290                (lambda (c)
 291                  (let*
 292                      ((cbn (ly:context-property c 'currentBarNumber)))
 293                    (if (not (= cbn n))
 294                        (ly:input-message location "Barcheck failed got ~a expect ~a"
 295                                          cbn n))))))
 296
 297
 298
 299 % for regression testing purposes.
 300 assertBeamQuant =
 301 #(define-music-function (parser location l r) (pair? pair?)
 302   (make-grob-property-override 'Beam 'positions
 303    (ly:make-simple-closure
 304     (ly:make-simple-closure
 305      (append
 306       (list chain-grob-member-functions `(,cons 0 0))
 307       (check-quant-callbacks l r))))))
 308
 309 % for regression testing purposes.
 310 assertBeamSlope =
 311 #(define-music-function (parser location comp) (procedure?)
 312   (make-grob-property-override 'Beam 'positions
 313    (ly:make-simple-closure
 314     (ly:make-simple-closure
 315      (append
 316       (list chain-grob-member-functions `(,cons 0 0))
 317       (check-slope-callbacks comp))))))
 318
 319
 320 parallelMusic =
 321 #(define-music-function (parser location voice-ids music) (list? ly:music?)
 322   "Define parallel music sequences, separated by '|' (bar check signs),
 323 and assign them to the identifiers provided in @var{voice-ids}.
 324
 325 @var{voice-ids}: a list of music identifiers (symbols containing only letters)
 326
 327 @var{music}: a music sequence, containing BarChecks as limiting expressions.
 328
 329 Example:
 330   \\parallelMusic #'(A B C) {
 331     c c | d d | e e |
 332     d d | e e | f f |
 333   }
 334 <==>
 335   A = { c c | d d | }
 336   B = { d d | e e | }
 337   C = { e e | f f | }
 338 "
 339   (let* ((voices (apply circular-list (make-list (length voice-ids) (list))))
 340          (current-voices voices)
 341          (current-sequence (list)))
 342     ;;
 343     ;; utilities
 344     (define (push-music m)
 345       "Push the music expression into the current sequence"
 346       (set! current-sequence (cons m current-sequence)))
 347     (define (change-voice)
 348       "Stores the previously built sequence into the current voice and
 349        change to the following voice."
 350       (list-set! current-voices 0 (cons (make-music 'SequentialMusic
 351                                          'elements (reverse! current-sequence))
 352                                         (car current-voices)))
 353       (set! current-sequence (list))
 354       (set! current-voices (cdr current-voices)))
 355     (define (bar-check? m)
 356       "Checks whether m is a bar check."
 357       (eq? (ly:music-property m 'name) 'BarCheck))
 358     (define (music-origin music)
 359       "Recursively search an origin location stored in music."
 360       (cond ((null? music) #f)
 361             ((not (null? (ly:music-property music 'origin)))
 362              (ly:music-property music 'origin))
 363             (else (or (music-origin (ly:music-property music 'element))
 364                       (let ((origins (remove not (map music-origin
 365                                                       (ly:music-property music 'elements)))))
 366                         (and (not (null? origins)) (car origins)))))))
 367     ;;
 368     ;; first, split the music and fill in voices
 369     (map-in-order (lambda (m)
 370                     (push-music m)
 371                     (if (bar-check? m) (change-voice)))
 372                   (ly:music-property music 'elements))
 373     (if (not (null? current-sequence)) (change-voice))
 374     ;; un-circularize `voices' and reorder the voices
 375     (set! voices (map-in-order (lambda (dummy seqs)
 376                                  (reverse! seqs))
 377                                voice-ids voices))
 378     ;;
 379     ;; set origin location of each sequence in each voice
 380     ;; for better type error tracking
 381     (for-each (lambda (voice)
 382                 (for-each (lambda (seq)
 383                             (set! (ly:music-property seq 'origin)
 384                                   (or (music-origin seq) location)))
 385                           voice))
 386               voices)
 387     ;;
 388     ;; check sequence length
 389     (apply for-each (lambda (. seqs)
 390                       (let ((moment-reference (ly:music-length (car seqs))))
 391                         (for-each (lambda (seq moment)
 392                                     (if (not (equal? moment moment-reference))
 393                                         (ly:music-message seq
 394                                          "Bars in parallel music don't have the same length")))
 395                           seqs (map-in-order ly:music-length seqs))))
 396            voices)
 397    ;;
 398    ;; bind voice identifiers to the voices
 399    (map (lambda (voice-id voice)
 400           (ly:parser-define! parser voice-id
 401                              (make-music 'SequentialMusic
 402                                'origin location
 403                                'elements voice)))
 404         voice-ids voices))
 405  ;; Return an empty sequence. this function is actually a "void" function.
 406  (make-music 'SequentialMusic 'void #t))
 407
 408
 409
 410
 411 %% this is a stub. Write your own to suit the spacing tweak output.
 412 spacingTweaks =
 413 #(define-music-function (parser location parameters) (list?)
 414    (make-music 'SequentialMusic 'void #t))
 415
 416 octave =
 417 #(define-music-function (parser location pitch-note) (ly:music?)
 418    "octave check"
 419
 420    (make-music 'RelativeOctaveCheck
 421                'origin location
 422                'pitch (pitch-of-note pitch-note)
 423                ))
 424
 425 addquote =
 426 #(define-music-function (parser location name music) (string? ly:music?)
 427    "Add a piece of music to be quoted "
 428    (add-quotable name music)
 429    (make-music 'SequentialMusic 'void #t))
 430
 431
 432 parenthesize =
 433 #(define-music-function (parser loc arg) (ly:music?)
 434    "Tag @var{arg} to be parenthesized."
 435
 436    (set! (ly:music-property arg 'parenthesize) #t)
 437    arg)