scm/auto-beam.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2000--2012 Jan Nieuwenhuizen <janneke@gnu.org>
   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 ;;  Determine whether an auto beam should be extended to the right
  19 ;;  of the current stem.  We start anywhere, except mid-measure in
  20 ;;  3/4 time. We end according to the follwing rules, in order of
  21 ;;  decreasing priority:
  22 ;;
  23 ;;  1. end <type>
  24 ;;  2. end <greater type>
  25 ;;  3. if 1-2 not specified,  end at beatStructure intervals
  26 ;;
  27 ;;  Rationale:
  28 ;;
  29 ;;  [user override]
  30 ;;  1. override for specific duration type
  31 ;;  2. overrides apply to shorter durations
  32 ;;
  33 ;;  defined in scm/time-signature-settings.scm:
  34 ;;  1. Default grouping for common time signatures
  35
  36 (define-public (default-auto-beam-check context dir measure-pos test-beam)
  37   (define (get name default)
  38     (let ((value (ly:context-property context name)))
  39       (if (not (null? value)) value default)))
  40
  41   (define (beaming<? a b)
  42     (ly:moment<? (fraction->moment (car a))
  43                  (fraction->moment (car b))))
  44
  45   (define (ending-moments group-list start-beat base-moment)
  46     (if (null? group-list)
  47         '()
  48         (let ((new-start (+ start-beat (car group-list))))
  49           (cons (ly:moment-mul (ly:make-moment new-start 1) base-moment)
  50                 (ending-moments (cdr group-list) new-start base-moment)))))
  51
  52   (define (larger-setting test-beam sorted-alist)
  53     (if (null? sorted-alist)
  54         '()
  55         (let* ((first-key (caar sorted-alist))
  56                (first-moment (fraction->moment first-key)))
  57           (if (moment<=? test-beam first-moment)
  58               (car sorted-alist)
  59               (larger-setting test-beam (cdr sorted-alist))))))
  60
  61   (define (beat-end? moment beat-structure)
  62     (pair? (member moment beat-structure)))  ;; member returns a list if found, not #t
  63
  64   ;; Start of actual auto-beam test routine
  65   ;;
  66   ;;
  67   ;; Don't start auto beams on grace notes
  68   (if (and (!= (ly:moment-grace-numerator (ly:context-now context)) 0)
  69            (= dir START))
  70       #f
  71       (let* ((base-moment (get 'baseMoment (ly:make-moment 1 4)))
  72              (measure-length (get 'measureLength (ly:make-moment 1 1)))
  73              (time-signature-fraction
  74               (get 'timeSignatureFraction '(4 . 4)))
  75              (beat-structure (get 'beatStructure '(1 1 1 1)))
  76              (beat-endings (ending-moments beat-structure 0 base-moment))
  77              (exceptions (sort (assoc-get 'end
  78                                           (get 'beamExceptions '())
  79                                           '())
  80                                beaming<?))
  81              (function (if (= dir START) 'begin 'end))
  82              (beam-half-measure (get 'beamHalfMeasure #t))
  83              (type (moment->fraction test-beam))
  84              (non-grace (ly:make-moment
  85                          (ly:moment-main-numerator measure-pos)
  86                          (ly:moment-main-denominator measure-pos)))
  87              (pos (if (ly:moment<? non-grace ZERO-MOMENT)
  88                       (ly:moment-add measure-length non-grace)
  89                       non-grace))
  90              (type-grouping (assoc-get type exceptions '()))
  91              (default-rule (if (null? type-grouping)
  92                                (larger-setting test-beam exceptions)
  93                                '()))
  94              (default-grouping (if (pair? default-rule)
  95                                    (cdr default-rule)
  96                                    '()))
  97              (default-beat-length (if (pair? default-rule)
  98                                       (car default-rule)
  99                                       '()))
 100              (exception-grouping (if (null? type-grouping)
 101                                      default-grouping
 102                                      type-grouping))
 103              (grouping-moment (if (null? type-grouping)
 104                                   (fraction->moment default-beat-length)
 105                                   test-beam))
 106              (exception-moments (ending-moments
 107                                  exception-grouping 0 grouping-moment)))
 108
 109         (if (= dir START)
 110             ;; Start rules -- #t if beam is allowed to start
 111             (or beam-half-measure ;; Start anywhere, but option for mid-measure
 112                 (not (equal? (ly:moment-add pos pos) measure-length))
 113                 (not (= 3 (car time-signature-fraction))) ;; in triple meter
 114                 (not (= (cdr type) ;; when the beamed note is 1/6 of a measure
 115                         (* 2 (cdr time-signature-fraction)))))
 116             ;; End rules -- #t if beam is required to end
 117             (or (= (ly:moment-main-numerator pos) 0) ;; end at measure beginning
 118                 (if (null? exception-grouping)
 119                     (beat-end? pos beat-endings) ;; no exception, so check beat ending
 120                     (member pos exception-moments))))))) ;; check exception rule
 121
 122 (define-public (extract-beam-exceptions music)
 123   "Creates a value useful for setting @code{beamExceptions} from @var{music}."
 124   (define (car> a b) (> (car a) (car b)))
 125   (define (beatify lst)
 126     ;; takes a collection of end points, sorts them, and returns the
 127     ;; non-zero differences as beaming pattern
 128     (let ((s (sort lst <)))
 129       (remove zero?
 130               (map - s (cons 0 s)))))
 131   ;; TODO: let this do something useful with simultaneous music.
 132   (let loop
 133       ((lst (extract-typed-music (unfold-repeats-fully (event-chord-reduce music))
 134                                  '(rhythmic-event bar-check)))
 135        (pos 0) (res '()))
 136     (cond ((null? lst)
 137            (list
 138             (cons 'end
 139                   (map
 140                    (lambda (l)
 141                      (cons (cons (numerator (car l)) (denominator (car l)))
 142                            (beatify (cdr l))))
 143                    (sort res car>)))))
 144           ((music-is-of-type? (car lst) 'bar-check)
 145            (loop (cdr lst) 0 res))
 146           ;; Have rhythmic event.
 147           ((any
 148             (lambda (art)
 149               (and (music-is-of-type? art 'beam-event)
 150                    (= (ly:music-property art 'span-direction START) STOP)))
 151             (ly:music-property (car lst) 'articulations))
 152            (let* ((dur (ly:music-property (car lst) 'duration))
 153                   (len (if (ly:duration? dur) (duration-length dur) 0))
 154                   (pos (+ pos len))
 155                   (ass (assoc len res)))
 156              (cond ((or (zero? len) (not (integer? (/ pos len))))
 157                     (ly:warning (car lst) (_ "Beam end fits no pattern"))
 158                     (loop (cdr lst) pos res))
 159                    (ass
 160                     (set-cdr! ass (cons (/ pos len) (cdr ass)))
 161                     (loop (cdr lst) pos res))
 162                    (else
 163                     (loop (cdr lst) pos (cons (list len (/ pos len)) res))))))
 164           (else
 165            (let* ((dur (ly:music-property (car lst) 'duration))
 166                   (len (if (ly:duration? dur) (duration-length dur) 0)))
 167              (loop (cdr lst)
 168                    (+ pos len)
 169                    res))))))