ly/articulate.ly

   1 %
   2 % Copyright (C) 2008, 2009, 2010, 2011 NICTA
   3 % Author: Peter Chubb <peter.chubb AT nicta.com.au>
   4 % $Id: articulate.ly,v 1.7 2011-03-24 00:40:00 peterc Exp $
   5 %
   6 %
   7 %  This program is free software; you can redistribute it and/or modify
   8 %  it under the terms of the GNU General Public License, version 3,
   9 %  as published by the Free Software Foundation.
  10 %
  11 %  WARNING: this file under GPLv3 only, not GPLv3+
  12 %
  13 %  This program is distributed in the hope that it will be useful,
  14 %  but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 %  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  16 %  See the GNU General Public License for more details.  It is
  17 %  available in the Lilypond source tree, or at
  18 %  http://www.gnu.org/licenses/gpl-3.0.html
  19 %
  20 % This script tries to make MIDI output from LilyPond a little more realistic.
  21 % It tries to take articulations (slurs, staccato, etc) into account, by
  22 % replacing notes  with sequential music of suitably time-scaled note plus
  23 % skip.
  24 %
  25 % Trills, turns, mordents and pralls are expanded with rallentendo
  26 % and accelerando taken into account.
  27 %
  28 % As my scheme knowledge is poor (I was teaching myself as I went), there
  29 % is much scope for improvement.
  30
  31 % See: http://nicta.com.au/people/chubbp/articulate for additional
  32
  33 % information about how the articulate function works.
  34
  35 %%% Supported items:
  36 % Slurs and phrasing slurs.
  37 % Ornaments (i.e. mordents, trills, turns).
  38 % Rallentando, accelerando, ritard and 'a tempo'.
  39 %
  40 % Please refer to 'MIDI output' (Section 3.5) in the Notation Reference
  41 % Manual for a more detailed list of supported items.
  42
  43 %%% Technical Details:
  44 % * Any note not under a slur or phrasing mark, and not marked with an
  45 % explicit articulation, is shortened by ac:normalFactor (default 7/8)
  46 % * Any note marked staccato is shortened by ac:staccatoFactor.
  47 % (default 1/2).
  48 % * Any note marked tenuto gets its full value.
  49 % * Appogiaturas are made to take half the value of the note following,
  50 % without taking dots into account (so in \appoggiatura c8 d2. the c
  51 % will take the time of a crotchet).
  52 % * Trills and turns are expanded. The algorithm tries to choose notes
  53 % within the time of the current tempo that lead to each twiddle being
  54 % around 1/8 seconds; this can be adjusted with the ac:maxTwiddleTime
  55 % variable.
  56 % * Rall, poco rall and a tempo are observed. It'd be fairly trivial to
  57 % make accel. and stringendo and so on work too.
  58
  59 %
  60 %%%USAGE
  61 % In the \score section do:
  62 % \articulate <<
  63 %       all the rest of the score
  64 % >>
  65 % or use the lilywrap script.
  66 %
  67 % TO DO:
  68 %
  69 % * Dynamics.
  70 %   * Fix quantisation for dynamics on single note (replace note
  71 %     with tied 128th notes?) -- started, needs work.
  72 %   * Make \fp do the right thing (loud start, then quiet).
  73 %
  74 % * Inegalite.  Notes on-beat steal time from notes off-beat.
  75 %   Degree of stealing is a parameter: from 1.0 (straight)
  76 %   to 1.5 (extreme swing).  Also fix tenuto to use this.
  77 %
  78 % * add accel (to match rall), and molto rall. I've never seen
  79 %   molto accel but some composer somewhere has probably used it.
  80 %
  81 % * Fermata, and Fermata Lunga
  82 % * Add more synonyms for accel and rall: rit ritard stringendo
  83 %
  84 % * Phrasing.
  85 %   * Rall at end of piece
  86 %   * Very slight accel into a phrase, rall out of it.
  87 %   * Dynamics during a phrase????  unclear how these should be in
  88 %     the general case
  89 %
  90 % * Trill algorithm needs work.
  91 %
  92 % * Cope with more ornaments/articulations.
  93 %    inverted-turns, etc.
  94 %   -- accent needs better control of dynamics.
  95 %   -- Articulations: mezzo-staccato, portato.
  96 %   -- Handling of generic ornaments (in lily, `\stopped'; in
  97 %               most early music:  ornament this note (trill, turn
  98 %               or mordent as the player wishes))
  99
 100 % * Automatic gruppetto at end of trill; better handling of
 101 %      initial/final grace notes on trill
 102
 103 % * Automatic ornaments.
 104 %   * Spot cadences and ornament
 105 %   * Look for quaver-dotted note for trills, for example.
 106 %   * Fill in steps. (Needs lookahead/lookbehind.)
 107 % * `afterturn' -- a turn after the start of a note.
 108 % * accidentals for trills and turns
 109
 110 % CHANGELOG
 111 %  * David Kastrup: remove redefinitions of \afterGrace and \appoggiatura
 112 %    and let their actions be performed when \articulate is called by
 113 %    recognizing and replacing LilyPond's default code for these constructs.
 114 %    Cf issue 4517 in LilyPond's tracker.
 115 %  * David Kastrup: basic 2.15.28 compatibility by using event-chord-wrap!
 116 %    This should really be done by rewriting the code more thoroughly.
 117 %  * From Iain Nicol: appoggiatura timings were out; add staccatissimo; fix
 118 %    trillSpanner endpoints.
 119 %  * Also handle Breathing events (by throwing them away).  This isn't ideal;
 120 %    one should really shorten the note before a little.  But I don't know
 121 %    how to do lookahead in scheme.
 122 %  * Also ignore explicit line breaks.
 123 %  * Add Mordents (reported by Patrick Karl)
 124 %
 125
 126 \version "2.19.22"
 127
 128 #(use-modules (srfi srfi-1))
 129 #(use-modules (srfi srfi-11))
 130 #(use-modules (ice-9 debug))
 131 #(use-modules (scm display-lily))
 132
 133 % PARAMETERS
 134 % How much to compress notes marked Staccato.  CPE Bach says `as short as
 135 % may conveniently be played, as if the keys were too hot to touch'.
 136 % Most modern sources say 1/2 the notated length of a note.
 137 #(define ac:staccatoFactor '(1 . 2))
 138
 139 % How much to compress notes marked staccatissimo.
 140 #(define ac:staccatissimoFactor '(1 . 4))
 141
 142 % And tenuto (if we ever implement time stealing, this should be >1.0)
 143 #(define ac:tenutoFactor '(1 . 1))
 144
 145 % How much to articulate normal notes.  CPE Bach says 1/2 (and
 146 % staccato should be `as short as may conveniently be played') but this
 147 % sounds too short for modern music.  7/8 sounds about right.
 148 #(define ac:normalFactor '(7 . 8))
 149
 150 % How much to slow down for a rall. or a poco rall.
 151 % (or speed up for accel or poco accel)
 152 #(define ac:rallFactor (ly:make-moment 60/100)) % 40% slowdown
 153 #(define ac:pocoRallFactor (ly:make-moment 90/100)) % 10% slowdown
 154
 155 % The absolute time for a twiddle in a trill, in minutes.
 156 % Start with 1/4 seconds == 1/240 minutes
 157 #(define ac:maxTwiddleTime (ly:make-moment 1/240))
 158
 159 % How long ordinary grace notes should be relative to their notated
 160 % duration.  9/40 is LilyPond's built-in behaviour for MIDI output
 161 % (though the notation reference says 1/4).
 162 #(define ac:defaultGraceFactor 9/40)
 163
 164 % What proportion of an ordinary grace note's time should be stolen
 165 % from preceding notes (as opposed to stealing from the principal note).
 166 % Composers' intentions for this vary.  Taking all from the preceding
 167 % notes is LilyPond's built-in behaviour for MIDI output.
 168 #(define ac:defaultGraceBackwardness 1)
 169
 170
 171 % Internal variables, don't touch.
 172 % (should probably be part of a context somehow)
 173
 174 % Whether to slur, or not
 175 #(define ac:inSlur #f)
 176 #(define ac:inPhrasingSlur #f)
 177
 178 % Whether the current noteevent is in a trill spanner
 179 #(define ac:inTrill #f)
 180
 181 % assume start in C major.  Key change events override this.
 182 % Could get from context, but don't know how.
 183 #(define ac:current-key (make-music
 184           'KeyChangeEvent
 185           'tonic
 186           (ly:make-pitch -1 0 0)
 187           'pitch-alist
 188           (list (cons 0 0)
 189                 (cons 1 0)
 190                 (cons 2 0)
 191                 (cons 3 0)
 192                 (cons 4 0)
 193                 (cons 5 0)
 194                 (cons 6 0))))
 195
 196
 197 #(define ac:currentTempo (ly:make-moment 15/1)) % 4 = 60, measured wholes per minute
 198 #(define ac:lastTempo ac:currentTempo) % for 'a tempo' or 'tempo I'
 199
 200 % The duration of the current note.  Start at a crotchet
 201 % for no good reason.
 202 #(define ac:currentDuration (ly:make-duration 2 0 1/1))
 203
 204 % Amount of musical time (in whole notes) that we need to steal from the
 205 % next events seen.
 206 #(define ac:stealForward 0)
 207
 208 % List of events in the output so far, in reverse order, from which we can
 209 % steal time.
 210 #(define ac:eventsBackward '())
 211
 212 % Log events for the backward chain.
 213 #(define (ac:logEventsBackward music)
 214   (music-map
 215    (lambda (m)
 216     (case (ly:music-property m 'name)
 217      ((EventChord)
 218       (set! ac:eventsBackward (cons m ac:eventsBackward))
 219       m)
 220      ((BarCheck SkipMusic)
 221       (let ((wm (make-sequential-music (list m))))
 222        (set! ac:eventsBackward (cons wm ac:eventsBackward))
 223        wm))
 224      (else
 225       m)))
 226    music))
 227
 228 % Steal time from the backward chain.  Adds to ac:stealForward (with a
 229 % warning) if it couldn't backward-steal all that was desired.
 230 #(define (ac:stealTimeBackward tosteal)
 231   (if (<= tosteal 0)
 232    #t
 233    (if (null? ac:eventsBackward)
 234     (begin
 235      (ly:warning (_ "articulation failed to steal ~a note backward at beginning of music; stealing forward instead") tosteal)
 236      (set! ac:stealForward (+ ac:stealForward tosteal)))
 237     (let*
 238      ((lastev (car ac:eventsBackward))
 239       (levlen (ly:moment-main (ly:music-length lastev))))
 240      (if (< tosteal levlen)
 241       (begin
 242        (ly:music-compress lastev (ly:make-moment (/ (- levlen tosteal) levlen)))
 243        #t)
 244       (begin
 245        (if (any (lambda (z) (eq? 'NoteEvent (ly:music-property z 'name)))
 246                 (ly:music-property lastev 'elements))
 247         (ly:warning (_ "stealing the entirety of a note's time")))
 248        (set! (ly:music-property lastev 'elements) '())
 249        (set! ac:eventsBackward (cdr ac:eventsBackward))
 250        (ac:stealTimeBackward (- tosteal levlen))))))))
 251
 252 % Debugging: display a moment plus some text.
 253 % Returns its moment argument so can be used in-line.
 254 #(define (display-moment  text m)
 255   (display text)
 256   (display (list (ly:moment-main-numerator m) "/" (ly:moment-main-denominator m)))
 257   m
 258 )
 259
 260 % Track tempo (and maybe later, other context properties)
 261 % as they change.  Needs to better cope with saving only Tempo I,
 262 % otherwise "a tempo" goes back to the tempo before the last change.
 263 #(define (ac:adjust-props sym music)
 264   (case sym
 265    ((tempoWholesPerMinute)
 266     (set! ac:currentTempo (ly:music-property music 'value))
 267     (set! ac:lastTempo ac:currentTempo)
 268   )))
 269
 270 % Raise note one step in the current diatonic scale.
 271 #(define (ac:up note)
 272   (let* ((pitch (ly:music-property note 'pitch))
 273          (notename (ly:pitch-notename pitch))
 274          (new-notename (if (eq? notename 6) 0 (+ 1 notename)))
 275          (alterations (ly:music-property ac:current-key 'pitch-alist))
 276          (new-alteration (cdr (assq new-notename alterations)))
 277          (new-octave (if (eq? new-notename 0) (+ 1 (ly:pitch-octave pitch))
 278                       (ly:pitch-octave pitch)))
 279        )
 280    (set! (ly:music-property note 'pitch)(ly:make-pitch new-octave new-notename new-alteration))))
 281
 282
 283 % Lower note one step in the current diatonic scale.
 284 #(define (ac:down note)
 285   (begin  (let* ((pitch (ly:music-property note 'pitch))
 286          (notename (ly:pitch-notename pitch))
 287          (new-notename (if (eq? notename 0) 6 (- notename 1)))
 288          (alterations (ly:music-property ac:current-key 'pitch-alist))
 289          (new-alteration (cdr (assq new-notename alterations)))
 290          (new-octave (if (eq? new-notename 6) (- (ly:pitch-octave pitch) 1)
 291                       (ly:pitch-octave pitch)))
 292        )
 293    (set! (ly:music-property note 'pitch)(ly:make-pitch new-octave new-notename new-alteration))))
 294 )
 295
 296 % Shorten a note, and save the note's original duration in ac:currentDuration
 297 #(define (ac:articulate-one-note m fraction)
 298   "Replace m with m*fraction"
 299   (if  (eq? 'NoteEvent (ly:music-property m 'name))
 300    (let*
 301     ((dur (ly:music-property m 'duration))
 302      (l (ly:duration-log dur))
 303      (d (ly:duration-dot-count dur))
 304      (factor (ly:duration-factor dur))
 305      (num (car fraction))
 306      (denom (cdr fraction)))
 307     (begin
 308      (set! ac:currentDuration dur)
 309      (set! (ly:music-property m 'duration)
 310       (ly:make-duration l d
 311        (* num (car factor))
 312        (* denom (cdr factor))))))
 313    m))
 314
 315 % helper routine to set duration.
 316 #(define (ac:setduration music duration)
 317   "Set a note's duration."
 318   (let ((eventtype (ly:music-property music 'name)))
 319    (if
 320     (or
 321      (eq? eventtype 'NoteEvent)
 322      (eq? eventtype 'RestEvent)
 323      (eq? eventtype 'SkipEvent))
 324     (set! (ly:music-property music 'duration) duration))))
 325
 326 % Add an articulation event to a note.
 327 % Used in afterGrace to mark all notes as tenuto, so they're not shortened
 328 #(define (ac:add-articulation type music)
 329     (music-map (lambda (m)
 330                 (if (eq? 'EventChord (ly:music-property m 'name))
 331                  (set! (ly:music-property m 'elements)
 332                   (append (ly:music-property m 'elements)
 333                    (list (make-music 'ArticulationEvent 'articulation-type type)))))
 334                 m)
 335      music))
 336
 337 % Convert a long note to an equivalent set of short notes, tied together.
 338 % This is needed to get smooth dynamics changes.
 339 % Need to deal properly with stuff other than the notes (dynamics, markup etc)
 340 % Still experimental, so disabled for now.
 341 #(define (ac:to128 music) music)
 342
 343 #(define (ac:to128_disabled music)
 344   (if (or (eq? 'SkipEvent (ly:music-property music 'name))
 345         (eq? 'NoteEvent (ly:music-property music 'name)))
 346    (let* ((dur (ly:music-property music 'duration))
 347           (log2 (ly:duration-log dur))
 348          (shiftcount (- 6 log2))
 349          (lastm (ly:music-deep-copy (shift-duration-log music shiftcount 0))))
 350    (set! (ly:music-property music 'elements)
 351     (cons (make-music 'TieEvent) (ly:music-property music 'elements)))
 352    (make-sequential-music (list
 353                            (make-repeat "unfold" (1- (expt 2 shiftcount))
 354                             (make-sequential-music (list music)) '())
 355                            lastm)))
 356  music))
 357
 358
 359 % absolute time in minutes of a length of music, as a rational number (moment)
 360 #(define (ac:abstime music)
 361   (ly:moment-div (ly:music-length music) ac:currentTempo))
 362
 363 % convert absolute time (in minutes) to a moment in the current tempo
 364 #(define (ac:abs->mom m)
 365   (ly:moment-mul m ac:currentTempo))
 366
 367
 368 % a moment that is ac:maxTwiddletime seconds at the current tempo.
 369 #(define (ac:targetTwiddleTime)
 370   (ac:abs->mom ac:maxTwiddleTime))
 371
 372
 373 % Nearest twiddletime (in minutes) achievable with power-of-2 divisions of
 374 % the original music.  (twiddletime is the time for one pair of notes
 375 % in a trill)
 376 % If the music has a precomputed twiddletime (e.g., from \afterGrace) use that.
 377 #(define (ac:twiddletime music)
 378   (let* ((tr (filter (lambda (x)
 379                      (and (eq? 'ArticulationEvent (ly:music-property x 'name))
 380                       (string= "trill" (ly:music-property x 'articulation-type))))
 381               (ly:music-property music 'elements)))
 382          (pre-t (if (pair? tr) (ly:music-property (car tr) 'twiddle)
 383                  '()))
 384          (hemisemimom (ly:make-moment 1/64))
 385          (t (ac:targetTwiddleTime)))
 386    (if (ly:moment? pre-t)
 387     pre-t
 388     hemisemimom)))
 389
 390
 391
 392 % Note: I'm assuming early music practice of starting on the auxiliary note.
 393 % Needs to add gruppetto if it's a long trill (TODO)
 394 #(define (ac:trill music)
 395   " Replace music with time-compressed repeats of the music,
 396     maybe accelerating if the length is longer than a crotchet "
 397   (let* ((hemisemidur (ly:make-duration 5 0 1/1))
 398          (orig-len  (ly:music-length music))
 399          (t (ac:twiddletime music))
 400          (uppernote '())
 401          (note_moment (ly:moment-mul t (ly:make-moment 1/2)))
 402          (c1 (ly:moment-div orig-len t))
 403          (c2 (inexact->exact
 404               (round (/ (ly:moment-main-numerator c1)
 405                       (* 2 (ly:moment-main-denominator c1))))))
 406          (count (if (< c2 2) 2 c2)))
 407
 408    (set! (ly:music-property music 'elements)
 409     (filter (lambda (y) (eq? 'NoteEvent (ly:music-property y 'name)))
 410      (ly:music-property music 'elements)))
 411    (map (lambda (y) (ac:setduration y hemisemidur))
 412     (ly:music-property music 'elements))
 413    (set! uppernote (ly:music-deep-copy music))
 414    (map (lambda (y) (ac:up y))
 415     (filter
 416      (lambda (z) (eq? 'NoteEvent (ly:music-property z 'name)))
 417      (ly:music-property uppernote 'elements)))
 418
 419    (let* ((trillMusicElements
 420           (let loop ((so_far (list uppernote music))
 421                      (c count))
 422            (if (> c 1)
 423             (loop (append (list (ly:music-deep-copy uppernote) (ly:music-deep-copy music)) so_far) (1- c))
 424             so_far)))
 425           (trillMusic (make-sequential-music trillMusicElements))
 426           (newlen (ly:music-length trillMusic))
 427           (factor (ly:moment-div  orig-len newlen)))
 428     (ly:music-compress trillMusic factor)
 429 ; accelerating the music seems to put lily into an infinite loop in
 430 ; its layout and midi engines.
 431 ;    (let* ((realfactor (exp (* (/ 1.0 count) (log 0.75))))
 432 ;          (factor (ly:make-moment (inexact->exact (round (* 1024 realfactor)))
 433 ;                   1024)))
 434 ;     (ac:accel trillMusic factor))
 435  )))
 436
 437
 438 % Copy music and strip articulations, ties, etc., for generating
 439 % mordents etc.
 440 #(define (ac:note-copy music)
 441   "return a copy of music that is only notes, no articulations, ties, slurs etc"
 442   (let ((new-music (ly:music-deep-copy music)))
 443    (set! (ly:music-property new-music 'articulations) '())
 444    (set! (ly:music-property new-music 'elements)
 445     (filter (lambda (y) (eq? 'NoteEvent (ly:music-property y 'name)))
 446      (ly:music-property new-music 'elements)))
 447    new-music))
 448
 449 %
 450 % Generate a tempoChangeEvent and its associated property setting.
 451 %
 452 #(define (ac:tempoChange tempo)
 453   (make-sequential-music
 454    (list (make-music 'TempoChangeEvent
 455           'metronome-count
 456           tempo
 457           'tempo-unit
 458           (ly:make-duration 0 0 1/1))
 459     (context-spec-music
 460     (make-property-set 'tempoWholesPerMinute  tempo) 'Score))))
 461
 462 %
 463 % Totally unfold repeats, so that the non-obvious sequencing doesn't
 464 % confuse us.  This is necessary for time stealing to work, because
 465 % that relies on the sequence in which we see events matching their
 466 % audible sequence.  Also unfold multi-measure rests to equivalent
 467 % skips, with preceding and following bar checks, so that time stealing
 468 % can change the length of the pause without falling foul of the
 469 % implicit bar checks.
 470 %
 471 #(define (ac:unfoldMusic music)
 472   (music-map
 473    (lambda (m)
 474     (case (ly:music-property m 'name)
 475      ((UnfoldedRepeatedMusic)
 476       (let
 477        ((body (ly:music-property m 'element))
 478         (altl (ly:music-property m 'elements))
 479         (rc (ly:music-property m 'repeat-count)))
 480        (if (null? altl)
 481         (make-sequential-music
 482          (list-tabulate rc (lambda (i) (ly:music-deep-copy body))))
 483         (let ((ealtl (if (> (length altl) rc) (take altl rc) altl)))
 484          (make-sequential-music
 485           (apply append!
 486            (append!
 487             (list-tabulate
 488              (- rc (length ealtl))
 489              (lambda (i) (list (ly:music-deep-copy body) (ly:music-deep-copy (car ealtl)))))
 490             (map (lambda (alt) (list (ly:music-deep-copy body) alt)) ealtl))))))))
 491      ((EventChord)
 492       (let-values
 493        (((trem evl)
 494          (partition (lambda (v) (eq? (ly:music-property v 'name) 'TremoloEvent))
 495           (ly:music-property m 'elements))))
 496        (if (null? trem)
 497         m
 498         (let*
 499          ((tremtype (ly:music-property (car trem) 'tremolo-type))
 500           (tremtype-log (1- (integer-length tremtype)))
 501           (durev (find (lambda (v) (not (null? (ly:music-property v 'duration)))) evl))
 502           (totaldur (if durev (ly:music-property durev 'duration) (ly:make-duration tremtype-log 0 1)))
 503           (tgt-nrep (/ (duration-visual-length totaldur) (duration-log-factor tremtype-log)))
 504           (eff-nrep (max (truncate tgt-nrep) 1))
 505           (tremdur (ly:make-duration tremtype-log 0
 506                     (* (/ tgt-nrep eff-nrep) (ly:duration-scale totaldur)))))
 507          (or (and (= eff-nrep tgt-nrep) (= (ash 1 tremtype-log) tremtype))
 508           (ly:warning (_ "non-integer tremolo ~a:~a")
 509            (duration->lily-string (duration-visual totaldur) #:force-duration #t #:time-scale 1)
 510            tremtype))
 511          (for-each
 512           (lambda (v)
 513            (or (null? (ly:music-property v 'duration))
 514             (set! (ly:music-property v 'duration) tremdur)))
 515           evl)
 516          (set! (ly:music-property m 'elements) evl)
 517          (make-sequential-music
 518           (list-tabulate eff-nrep (lambda (i) (ly:music-deep-copy m))))))))
 519      ((MultiMeasureRestMusic)
 520       (make-sequential-music
 521        (list
 522         (make-music 'BarCheck)
 523         (make-music 'SkipMusic 'duration (ly:music-property m 'duration))
 524         (make-music 'BarCheck))))
 525      (else
 526       m)))
 527    (unfold-repeats music)))
 528
 529 % If there's an articulation, use it.
 530 % If in a slur, use (1 . 1) instead.
 531 % Treat phrasing slurs as slurs, but allow explicit articulation.
 532 % (Maybe should treat staccato under a phrasing slur as mezzo-staccato?)
 533 %
 534 % Expect an EventChord.
 535 %
 536 % trills, turns, ornaments etc.  are also treated as Articulations.
 537 % Split into two functions:
 538 %  ac:getactions traverses the elements in the EventChord
 539 %               and calculates the parameters.
 540 %  ac:articulate-chord applies the actions to each NoteEvent in
 541 %               the EventChord.
 542 #(define (ac:getactions music)
 543   (let  loop ((factor ac:normalFactor)
 544               (newelements '())
 545               (es (ly:music-property music 'elements))
 546               (actions '()))
 547    (if (null? es)
 548     (begin
 549      (set! (ly:music-property music 'elements) (reverse newelements))
 550      (if
 551       (not (any (lambda (m) (music-is-of-type? m 'rhythmic-event))
 552                 newelements))
 553       actions
 554       (append
 555        (let ((st ac:stealForward))
 556         (if (= st 0)
 557          '()
 558          (begin
 559           (set! ac:stealForward 0)
 560           (list 'steal st))))
 561        actions
 562        (cond
 563         (ac:inTrill '(trill))
 564         ((and (eq? factor ac:normalFactor) (or ac:inSlur ac:inPhrasingSlur))
 565          (list 'articulation  '(1 . 1)))
 566         (else (list 'articulation  factor))))))
 567     ; else part
 568     (let ((e (car es))
 569           (tail (cdr es)))
 570      (case (ly:music-property e 'name)
 571
 572       ((BeamEvent) ; throw away beam events, or they'll be duplicated by turn or trill
 573        (loop factor newelements tail actions))
 574
 575       ((LineBreakEvent FingeringEvent MarkEvent BreathingEvent TieEvent SkipEvent RestEvent) ; pass through some events.
 576        (loop (cons 1 1) (cons e newelements) tail actions))
 577
 578       ((ArticulationEvent)
 579        (let ((articname (ly:music-property e 'articulation-type)))
 580         ; TODO: add more here
 581         (cond
 582          ((string= articname "staccato")
 583           (loop ac:staccatoFactor newelements tail actions))
 584          ((string= articname "staccatissimo")
 585           (loop ac:staccatissimoFactor newelements tail actions))
 586          ((string= articname "tenuto")
 587           (loop ac:tenutoFactor newelements tail actions))
 588          ((string= articname "mordent")
 589           (loop (cons 1 1) newelements tail (cons 'mordent actions)))
 590          ((string= articname "prall")
 591           (loop (cons 1 1) newelements tail (cons 'prall actions)))
 592          ((string= articname "trill")
 593           (loop (cons 1 1) newelements tail (cons 'trill actions)))
 594          ((string= articname "turn")
 595           (loop (cons 1 1) newelements tail (cons 'turn actions)))
 596          (else (loop factor (cons e newelements) tail actions)))))
 597
 598       ((TextScriptEvent)
 599        (let ((t (ly:music-property e 'text)))
 600         (if (not (string? t))
 601          (loop factor (cons e newelements) tail actions)
 602          (begin
 603           (cond
 604            ((or
 605              (string= t "rall")
 606              (string= t "Rall")
 607              (string= t "rit.")
 608              (string= t "rall."))
 609             (loop factor (cons e newelements) tail (cons 'rall actions)))
 610            ((or
 611              (string= t "accelerando")
 612              (string= t "accel")
 613              (string= t "accel."))
 614             (loop factor (cons e newelements) tail (cons 'accel actions)))
 615            ((or
 616              (string= t "poco accel."))
 617             (loop factor (cons e newelements) tail (cons 'pocoAccel actions)))
 618            ((or
 619              (string= t "poco rall.")
 620              (string= t "poco rit."))
 621             (loop factor (cons e newelements) tail (cons 'pocoRall actions)))
 622            ((or (string= t "a tempo")
 623              (string= t "tempo I"))
 624           (loop factor (cons e newelements) tail (cons 'aTempo actions)))
 625            (else (loop factor (cons e newelements) tail actions)))))))
 626
 627       ((SlurEvent)
 628        (let ((direction (ly:music-property e 'span-direction)))
 629         (set! ac:inSlur (eq? direction -1))
 630         (loop factor newelements tail actions)))
 631
 632       ((TrillSpanEvent)
 633        (let ((direction (ly:music-property e 'span-direction)))
 634         (set! ac:inTrill (eq? direction -1))
 635         (if ac:inTrill
 636          (loop factor newelements tail (cons 'trill actions))
 637          (loop factor (cons e newelements) tail actions))))
 638
 639       ((PhrasingSlurEvent)
 640        (let ((direction (ly:music-property e 'span-direction)))
 641         (set! ac:inPhrasingSlur (eq? direction -1))
 642         (loop factor newelements tail actions)))
 643
 644       (else (loop factor (cons e newelements) tail actions)))))))
 645
 646
 647
 648 #(define (ac:articulate-chord music)
 649   (cond
 650    ((eq? 'EventChord (ly:music-property music 'name))
 651     (ac:logEventsBackward
 652      (let loop ((actions (ac:getactions music)))
 653       (if (null? actions)
 654         (if (ly:moment<? (ly:make-moment 1/4) (ly:music-length music))
 655          (ac:to128  music)
 656          music)
 657
 658       (case (car actions)
 659
 660        ((articulation)
 661         (map
 662          (lambda (x) (ac:articulate-one-note x (cadr actions)))
 663          (ly:music-property music 'elements))
 664         (let*
 665          ((num (caadr actions))
 666           (denom (cdadr actions))
 667           (mult (ly:duration-factor ac:currentDuration))
 668           (newnum (* (- denom num) (car mult)))
 669           (newdenom (* (cdr mult) denom))
 670           (len (ly:duration-log ac:currentDuration))
 671           (dots (ly:duration-dot-count ac:currentDuration)))
 672
 673          (if (not (eq? num denom))
 674           (make-sequential-music
 675            (list (ac:to128 music)
 676            (make-music 'EventChord 'elements
 677             (list
 678              (make-music 'RestEvent 'duration (ly:make-duration len dots newnum newdenom))))))
 679           music)))
 680
 681        ((accel)
 682         (set! ac:lastTempo ac:currentTempo)
 683         (set! ac:currentTempo (ly:moment-div ac:currentTempo ac:rallFactor))
 684         (let ((pset (ac:tempoChange ac:currentTempo)))
 685          (if (null? (cdr actions))
 686           (make-sequential-music (list pset music))
 687           (make-sequential-music
 688            (list pset (loop (cdr actions)))))))
 689
 690        ((pocoAccel)
 691         (set! ac:lastTempo ac:currentTempo)
 692         (set! ac:currentTempo (ly:moment-div ac:currentTempo ac:pocoRallFactor))
 693         (let ((pset (ac:tempoChange ac:currentTempo)))
 694          (if (null? (cdr actions))
 695           (make-sequential-music (list pset music))
 696           (make-sequential-music
 697            (list pset (loop (cdr actions)))))))
 698
 699        ((rall)
 700         (set! ac:lastTempo ac:currentTempo)
 701         (set! ac:currentTempo (ly:moment-mul ac:currentTempo ac:rallFactor))
 702         (let ((pset (ac:tempoChange ac:currentTempo)))
 703          (if (null? (cdr actions))
 704           (make-sequential-music (list pset music))
 705           (make-sequential-music
 706            (list pset (loop (cdr actions)))))))
 707
 708        ((pocoRall)
 709         (set! ac:lastTempo ac:currentTempo)
 710         (set! ac:currentTempo (ly:moment-mul ac:currentTempo ac:pocoRallFactor))
 711         (let ((pset (ac:tempoChange ac:currentTempo)))
 712          (if (null? (cdr actions))
 713           (make-sequential-music (list pset music))
 714           (make-sequential-music
 715            (list pset (loop (cdr actions)))))))
 716
 717        ((aTempo)
 718         (set! ac:currentTempo ac:lastTempo)
 719
 720         (let ((pset (ac:tempoChange ac:currentTempo)))
 721          (if (null? (cdr actions))
 722           (make-sequential-music (list pset music))
 723           (make-sequential-music
 724            (list pset (loop (cdr actions)))))))
 725
 726        ((trill)
 727          (ac:trill music))
 728
 729        ((prall)
 730         ; A pralltriller symbol can either mean an inverted mordent
 731         ; or a half-shake -- a short, two twiddle trill.
 732         ; We implement as a half-shake.
 733         (let*
 734          ((origlength (ly:music-length music))
 735           (gracedur (ly:make-duration 5 0 1/1))
 736           (gracenote (ac:note-copy music))
 737           (abovenote (ac:note-copy music))
 738           (abovenoteTwo (ac:note-copy music))
 739           (mainnote (ly:music-deep-copy music)))
 740
 741          (map (lambda (y) (ac:setduration y gracedur))
 742           (ly:music-property gracenote 'elements))
 743          (map (lambda (y) (ac:setduration y gracedur))
 744           (ly:music-property abovenote 'elements))
 745          (map (lambda (y) (ac:setduration y gracedur))
 746           (ly:music-property abovenoteTwo 'elements))
 747          (map (lambda (y) (ac:up y))
 748           (filter
 749            (lambda (z) (eq? 'NoteEvent (ly:music-property z 'name)))
 750            (ly:music-property abovenote 'elements)))
 751          (map (lambda (y) (ac:up y))
 752           (filter
 753            (lambda (z) (eq? 'NoteEvent (ly:music-property z 'name)))
 754            (ly:music-property abovenoteTwo 'elements)))
 755          (let* ((prallMusic (make-sequential-music
 756                               (list abovenote gracenote abovenoteTwo mainnote)))
 757                  (newlen (ly:music-length prallMusic))
 758                  (factor (ly:moment-div origlength newlen)))
 759            (ly:music-compress prallMusic factor))))
 760
 761        ((mordent)
 762         (let*
 763          ((origlength (ly:music-length music))
 764           (gracedur (ly:make-duration 5 0 1/1))
 765           (gracenote (ac:note-copy music))
 766           (belownote (ac:note-copy music)))
 767          (map (lambda (y) (ac:setduration y gracedur))
 768           (ly:music-property gracenote 'elements))
 769          (map (lambda (y) (ac:setduration y gracedur))
 770                (ly:music-property belownote 'elements))
 771          (map (lambda (y) (ac:down y))
 772           (filter
 773            (lambda (z) (eq? 'NoteEvent (ly:music-property z 'name)))
 774            (ly:music-property belownote 'elements)))
 775
 776          (let* ((mordentMusic (make-sequential-music (list gracenote belownote music)))
 777                 (newlen (ly:music-length mordentMusic))
 778                 (factor (ly:moment-div origlength newlen)))
 779           (ly:music-compress mordentMusic factor))))
 780
 781        ((turn)
 782         (let*
 783          ((dur (ly:music-property
 784                 (car (ly:music-property music 'elements)) 'duration))
 785           (factor (ly:duration-factor dur))
 786           (newdur (ly:make-duration (+ (ly:duration-log dur) 2)
 787                    (ly:duration-dot-count dur) (car factor)(cdr factor))))
 788          (begin
 789           (map (lambda (y) (ac:setduration y newdur))
 790            (ly:music-property music 'elements))
 791           (let* ((above (ly:music-deep-copy music))
 792                  (below (ly:music-deep-copy music))
 793                  (newmusic (make-sequential-music (list above music below music))))
 794            (begin
 795             (map (lambda (y) (ac:down y))
 796              (filter
 797               (lambda (z) (eq? 'NoteEvent (ly:music-property z 'name)))
 798               (ly:music-property below 'elements)))
 799             (map (lambda (y) (ac:up y))
 800              (filter
 801               (lambda (z) (eq? 'NoteEvent (ly:music-property z 'name)))
 802               (ly:music-property above 'elements)))
 803             newmusic)))))
 804        ((steal)
 805         (let
 806          ((totallen (ly:moment-main (ly:music-length music)))
 807           (steallen (cadr actions)))
 808          (if (>= steallen totallen)
 809           (begin
 810            (if (any (lambda (z) (eq? 'NoteEvent (ly:music-property z 'name)))
 811                     (ly:music-property music 'elements))
 812             (ly:warning (_ "stealing the entirety of a note's time")))
 813            (set! ac:stealForward (- steallen totallen))
 814            (make-sequential-music '()))
 815           (begin
 816            (ly:music-compress music (ly:make-moment (/ (- totallen steallen) totallen)))
 817            (loop (cddr actions))))))
 818      )))))
 819
 820    ((eq? 'GraceMusic (ly:music-property music 'name))
 821     (let
 822      ((first-ev
 823        (call-with-current-continuation
 824         (lambda (yield-fev)
 825          (music-map
 826           (lambda (m)
 827            (if (eq? 'EventChord (ly:music-property m 'name))
 828             (yield-fev m)
 829             m))
 830           music)
 831          #f))))
 832      (if first-ev
 833       (let ((fev-pos (find-tail (lambda (m) (eq? m first-ev)) ac:eventsBackward)))
 834        (if fev-pos
 835         (set! ac:eventsBackward (cdr fev-pos))
 836         (ly:warning (_ "articulation of grace notes has gone awry"))))))
 837     (let*
 838      ((gmus (ly:music-compress (ly:music-property music 'element)
 839                                (ly:make-moment ac:defaultGraceFactor)))
 840       (glen (ly:moment-main (ly:music-length gmus))))
 841      (ac:stealTimeBackward (* glen ac:defaultGraceBackwardness))
 842      (set! ac:stealForward (+ ac:stealForward (* glen (- 1 ac:defaultGraceBackwardness))))
 843      gmus))
 844
 845    ((memq (ly:music-property music 'name) '(BarCheck SkipMusic))
 846     (let ((totallen (ly:moment-main (ly:music-length music)))
 847           (steallen ac:stealForward))
 848      (cond
 849       ((= steallen 0)
 850        (ac:logEventsBackward music))
 851       ((< steallen totallen)
 852        (set! ac:stealForward 0)
 853        (ac:logEventsBackward
 854         (ly:music-compress music (ly:make-moment (/ (- totallen steallen) totallen)))))
 855       (else
 856        (set! ac:stealForward (- steallen totallen))
 857        (make-sequential-music '())))))
 858
 859    ((eq? 'KeyChangeEvent (ly:music-property music 'name))
 860     (set! ac:current-key music)
 861     music)
 862
 863    ((eq? 'PropertySet (ly:music-property music 'name))
 864     (ac:adjust-props (ly:music-property music 'symbol) music)
 865     music)
 866
 867    (else music)))
 868
 869
 870
 871 % At last ... here's the music function that applies all the above to a
 872 % score.
 873 articulate = #(define-music-function (music)
 874                (ly:music?)
 875                "Adjust times of note to add tenuto, staccato and
 876                 normal articulations.
 877                 "
 878                (dynamic-wind
 879                 (lambda ()
 880                  (set! ac:stealForward 0)
 881                  (set! ac:eventsBackward '()))
 882                 (lambda ()
 883                  (music-map
 884                   ac:articulate-chord
 885                   (ac:startup-replacements music)))
 886                 (lambda ()
 887                  (or (= ac:stealForward 0)
 888                   (begin
 889                    (ly:warning (_ "articulation failed to steal ~a note at end of music") ac:stealForward)
 890                    (set! ac:stealForward 0)))
 891                  (set! ac:eventsBackward '()))))
 892
 893 #(define (ac:startup-replacements music)
 894    (fold (lambda (f m) (f m))
 895          music
 896          (list
 897           event-chord-wrap!
 898           ac:replace-aftergrace
 899           ac:replace-appoggiatura
 900           ac:unfoldMusic)))
 901
 902 #(define (ac:replace-aftergrace music)
 903    (map-some-music
 904     (lambda (expr)
 905       (with-music-match
 906        (expr (music 'SimultaneousMusic
 907                     elements (?before-grace
 908                               (music 'SequentialMusic
 909                                      elements ((music 'SkipMusic)
 910                                                (music 'GraceMusic
 911                                                       element ?grace))))))
 912        (ac:aftergrace ?before-grace ?grace)))
 913     music))
 914
 915 #(define (ac:replace-appoggiatura music)
 916    ;; appoggiature are ugly to deal with since they require a main
 917    ;; note following them.  We only try dealing with this followership
 918    ;; in sequential music
 919    (map-some-music
 920     (lambda (m)
 921       (if (eq? 'SequentialMusic (ly:music-property m 'name))
 922           (pair-for-each
 923            (lambda (elts)
 924              (let ((expr (car elts))
 925                    (main (and (pair? (cdr elts)) (cadr elts))))
 926                (and main
 927                     ;;stolen from define-music-display-methods
 928                     (with-music-match
 929                      (expr (music
 930                             'GraceMusic
 931                             element (music
 932                                      'SequentialMusic
 933                                      elements (?start
 934                                                ?music
 935                                                ?stop))))
 936                      ;; we check whether ?start and ?stop look like
 937                      ;; startAppoggiaturaMusic stopAppoggiaturaMusic
 938                      (and (with-music-match (?start (music
 939                                                      'SequentialMusic
 940                                                      elements ((music
 941                                                                 'EventChord
 942                                                                 elements
 943                                                                 ((music
 944                                                                   'SlurEvent
 945                                                                   span-direction START))))))
 946                                             #t)
 947                           (with-music-match (?stop (music
 948                                                     'SequentialMusic
 949                                                     elements ((music
 950                                                                'EventChord
 951                                                                elements
 952                                                                ((music
 953                                                                  'SlurEvent
 954                                                                  span-direction STOP))))))
 955                                             #t)
 956                           (let* ((app (ac:appoggiatura ?music main))
 957                                  (apps (ly:music-property app 'elements)))
 958                             (set-car! elts (car apps))
 959                             (set-car! (cdr elts) (cadr apps))
 960                             #f))))))
 961            (ly:music-property m 'elements)))
 962       #f)
 963     music))
 964
 965 % Override \afterGrace to be in terms of audio, not spacing.
 966 % Special handling for a gruppetto after a trill.
 967 #(define (ac:aftergrace main grace)
 968   (let*
 969    ((main-length (ly:music-length main))
 970     (grace-orig-length (ly:music-length grace))
 971     (gracelen (ac:twiddletime main))
 972     (grace-factor (ly:moment-div gracelen grace-orig-length))
 973     (new-main-length (ly:moment-sub main-length gracelen))
 974     (factor (ly:moment-div new-main-length main-length))
 975   )
 976    (map (lambda (y) (set! (ly:music-property y 'twiddle) gracelen))
 977          (filter (lambda (z)
 978                   (and
 979                    (eq? 'ArticulationEvent (ly:music-property z 'name))
 980                    (string= "trill" (ly:music-property z 'articulation-type))))
 981           (ly:music-property main 'elements)))
 982    (ac:add-articulation "tenuto" grace)
 983    (make-sequential-music  (list (ly:music-compress main factor) (ly:music-compress grace grace-factor)))))
 984
 985 % An appoggiatura takes half the duration of the main note,
 986 % or 1/3 if the note is dotted (i.e., half the undotted equivalent time)
 987 % Somewhere around the end of the 19th, start of 20th century the rules
 988 % changed, but my main interest is early music.
 989 #(define (ac:appoggiatura grace main)
 990   (let* ((maindur (ly:music-length main))
 991          (grace-orig-len (ly:music-length grace))
 992          (main-orig-len (ly:music-length main))
 993          (numerator (ly:moment-main-numerator maindur))
 994          (factor (if (eq? (remainder numerator 3) 0)
 995                   (ly:make-moment 1/3) (ly:make-moment 1/2))))
 996    (ly:music-compress grace
 997     (ly:moment-mul factor (ly:moment-div main-orig-len grace-orig-len)))
 998    (ly:music-compress main (ly:moment-sub (ly:make-moment 1/1) factor))
 999
1000     (set! (ly:music-property grace 'elements)
1001      (append (ly:music-property grace 'elements)
1002       (list (make-music 'SlurEvent 'span-direction -1))))
1003     (set! (ly:music-property main 'elements)
1004      (append (ly:music-property main 'elements)
1005       (list (make-music 'SlurEvent 'span-direction 1))))
1006      (make-sequential-music (list grace main))))