scm/scheme-engravers.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2012 David Nalesnik <david.nalesnik@gmail.com>
   4 ;;;;
   5 ;;;; LilyPond is free software: you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation, either version 3 of the License, or
   8 ;;;; (at your option) any later version.
   9 ;;;;
  10 ;;;; LilyPond is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 (define-public (ly:make-listener callback)
  19   "This is a compatibility wrapper for creating a \"listener\" for use
  20 with @code{ly:add-listener} from a @var{callback} taking a single
  21 argument.  Since listeners are equivalent to callbacks, this is no
  22 longer needed."
  23   callback)
  24
  25 (define-public (Measure_counter_engraver context)
  26   "This engraver numbers ranges of measures, which is useful in parts as an
  27 aid for counting repeated measures.  There is no requirement that the
  28 affected measures be repeated, however.  The user delimits the area to
  29 receive a count with @code{\\startMeasureCount} and
  30 @code{\\stopMeasureCount}."
  31   (let ((count-spanner '()) ; a single element of the count
  32         (go? #f) ; is the count in progress?
  33         (stop? #f) ; do we end the count?
  34         (last-measure-seen 0)
  35         (elapsed 0))
  36
  37     (make-engraver
  38      (listeners
  39       ((measure-counter-event engraver event)
  40        (cond
  41         ((and (= START (ly:event-property event 'span-direction))
  42               go?)
  43          (set! stop? #t)
  44          (ly:input-warning
  45           (ly:event-property event 'origin)
  46           "count not ended before another begun"))
  47         ((= START (ly:event-property event 'span-direction))
  48          (set! go? #t)
  49          ;; initialize one less so first measure receives a count spanner
  50          (set! last-measure-seen
  51                (1- (ly:context-property context 'currentBarNumber))))
  52         ((= STOP (ly:event-property event 'span-direction))
  53          (set! stop? #t)
  54          (set! go? #f)))))
  55
  56      ((process-music trans)
  57       (let ((col (ly:context-property context 'currentCommandColumn))
  58             (now (ly:context-property context 'measurePosition))
  59             (current-bar (ly:context-property context 'currentBarNumber)))
  60         ;; Each measure of a count receives a new spanner, which is bounded
  61         ;; by the first "command column" of that measure and the following one.
  62         ;; The possibility of initial grace notes (negative measure position)
  63         ;; is considered.
  64         (if (and (> current-bar last-measure-seen)
  65                  (moment<=? now ZERO-MOMENT))
  66             (begin
  67               ;; Finish the previous count-spanner if there is one.
  68               (if (ly:grob? count-spanner)
  69                   (begin
  70                     (ly:spanner-set-bound! count-spanner RIGHT col)
  71                     (ly:pointer-group-interface::add-grob count-spanner 'columns col)
  72                     (ly:engraver-announce-end-grob trans count-spanner col)
  73                     (set! count-spanner '())))
  74               ;; If count is over, reset variables.
  75               (if stop?
  76                   (begin
  77                     (set! elapsed 0)
  78                     (set! stop? #f)))
  79               ;; If count is in progress, begin a count-spanner.
  80               (if go?
  81                   (let* ((c (ly:engraver-make-grob trans 'MeasureCounter col))
  82                          (counter (ly:grob-property c 'count-from)))
  83                     (ly:spanner-set-bound! c LEFT col)
  84                     (ly:pointer-group-interface::add-grob c 'columns col)
  85                     (set! (ly:grob-property c 'count-from) (+ counter elapsed))
  86                     (set! count-spanner c)
  87                     (set! elapsed (1+ elapsed))))))
  88         (set! last-measure-seen current-bar)))
  89
  90      ((finalize trans)
  91       (if go?
  92           (begin
  93             (set! go? #f)
  94             (ly:grob-suicide! count-spanner)
  95             (set! count-spanner '())
  96             (ly:warning "measure count left unfinished")))))))
  97
  98 (ly:register-translator
  99  Measure_counter_engraver 'Measure_counter_engraver
 100  '((grobs-created . (MeasureCounter))
 101    (events-accepted . (measure-counter-event))
 102    (properties-read . (currentCommandColumn
 103                        measurePosition
 104                        currentBarNumber))
 105    (properties-written . ())
 106    (description . "\
 107 This engraver numbers ranges of measures, which is useful in parts as an
 108 aid for counting repeated measures.  There is no requirement that the
 109 affected measures be repeated, however.  The user delimits the area to
 110 receive a count with @code{\\startMeasureCount} and
 111 @code{\\stopMeasureCount}.")))
 112
 113 (ly:register-translator
 114  Span_stem_engraver 'Span_stem_engraver
 115  '((grobs-created . (Stem))
 116    (events-accepted . ())
 117    (properties-read . ())
 118    (properties-written . ())
 119    (description . "Connect cross-staff stems to the stems above in the system")))
 120
 121 (define-public (Merge_rests_engraver context)
 122 "Engraver to merge rests in multiple voices on the same staff.
 123
 124 This works by gathering all rests at a time step. If they are all of the same
 125 length and there are at least two they are moved to the correct location as
 126 if there were one voice."
 127
 128   (define (is-single-bar-rest? mmrest)
 129     (eqv? (ly:grob-property mmrest 'measure-count) 1))
 130
 131   (define (is-whole-rest? rest)
 132     (eqv? (ly:grob-property rest 'duration-log) 0))
 133
 134   (define (mmrest-offset mmrest)
 135   "For single measures they should hang from the second line from the top
 136   (offset of 1). For longer multimeasure rests they should be centered on the
 137   middle line (offset of 0).
 138   NOTE: For one-line staves full single measure rests should be positioned at
 139   0, but I don't anticipate this engraver's use in that case. No errors are
 140   given in this case."
 141     (if (is-single-bar-rest? mmrest) 1 0))
 142
 143   (define (rest-offset rest)
 144     (if (is-whole-rest? rest) 1 0))
 145
 146   (define (rest-eqv rest-len-prop)
 147     "Compare rests according the given property"
 148     (define (rest-len rest) (ly:grob-property rest rest-len-prop))
 149     (lambda (rest-a rest-b)
 150       (eqv? (rest-len rest-a) (rest-len rest-b))))
 151
 152   (define (rests-all-unpitched rests)
 153     "Returns true when all rests do not override the staff-position grob
 154     property. When a rest has a position set we do not want to merge rests at
 155     that position."
 156     (every (lambda (rest) (null? (ly:grob-property rest 'staff-position))) rests))
 157
 158   (define (merge-mmrests rests)
 159   "Move all multimeasure rests to the single voice location."
 160     (if (all-equal rests (rest-eqv 'measure-count))
 161       (merge-rests rests mmrest-offset)))
 162
 163   (define (merge-rests rests offset-function)
 164     (let ((y-offset (offset-function (car rests))))
 165       (for-each
 166         (lambda (rest) (ly:grob-set-property! rest 'Y-offset y-offset))
 167         rests))
 168     (for-each
 169       (lambda (rest) (ly:grob-set-property! rest 'transparent #t))
 170       (cdr rests)))
 171
 172   (define has-one-or-less (lambda (lst) (or (null? lst) (null? (cdr lst)))))
 173   (define has-at-least-two (lambda (lst) (not (has-one-or-less lst))))
 174   (define (all-equal lst pred)
 175     (or (has-one-or-less lst)
 176         (and (pred (car lst) (cadr lst)) (all-equal (cdr lst) pred))))
 177
 178   (let ((curr-mmrests '())
 179         (mmrests '())
 180         (rests '()))
 181     (make-engraver
 182       ((start-translation-timestep translator)
 183         (set! rests '())
 184         (set! curr-mmrests '()))
 185       (acknowledgers
 186         ((rest-interface engraver grob source-engraver)
 187           (cond
 188             ((ly:context-property context 'suspendRestMerging #f)
 189               #f)
 190             ((grob::has-interface grob 'multi-measure-rest-interface)
 191               (set! curr-mmrests (cons grob curr-mmrests)))
 192             (else
 193               (set! rests (cons grob rests))))))
 194       ((stop-translation-timestep translator)
 195         (if (and
 196               (has-at-least-two rests)
 197               (all-equal rests (rest-eqv 'duration-log))
 198               (rests-all-unpitched rests))
 199           (merge-rests rests rest-offset))
 200         (if (has-at-least-two curr-mmrests)
 201           (set! mmrests (cons curr-mmrests mmrests))))
 202       ((finalize translator)
 203         (for-each merge-mmrests mmrests)))))