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 (ending-moments group-list start-beat base-length)
  42     (if (null? group-list)
  43         '()
  44         (let ((new-start (+ start-beat (car group-list))))
  45           (cons (* new-start base-length)
  46                 (ending-moments (cdr group-list) new-start base-length)))))
  47
  48   (define (larger-setting type sorted-alist)
  49     (assoc type sorted-alist <=))
  50
  51   (define (beat-end? moment beat-endings)
  52     (pair? (memv moment beat-endings)))  ;; member returns a list if found, not #t
  53
  54   ;; Start of actual auto-beam test routine
  55   ;;
  56   ;;
  57   ;; Don't start auto beams on grace notes
  58   (and (or (zero? (ly:moment-grace (ly:context-now context)))
  59            (!= dir START))
  60       (let* ((base-length (cond ((get 'baseMoment #f) => ly:moment-main)
  61                                 (else 1/4)))
  62              (measure-length (cond ((get 'measureLength #f) => ly:moment-main)
  63                                    (else 1)))
  64              (time-signature-fraction
  65               (get 'timeSignatureFraction '(4 . 4)))
  66              (beat-structure (get 'beatStructure '(1 1 1 1)))
  67              (beat-endings (ending-moments beat-structure 0 base-length))
  68              (exceptions (sort (map
  69                                 (lambda (a)
  70                                   (if (pair? (car a))
  71                                       (cons (/ (caar a) (cdar a))
  72                                             (cdr a))
  73                                       a))
  74                                 (assoc-get 'end
  75                                            (get 'beamExceptions '())
  76                                            '()))
  77                                car<))
  78              (function (if (= dir START) 'begin 'end))
  79              (beam-half-measure (get 'beamHalfMeasure #t))
  80              (type (ly:moment-main test-beam))
  81              (non-grace (ly:moment-main measure-pos))
  82              (pos (if (negative? non-grace)
  83                       (+ measure-length non-grace)
  84                       non-grace))
  85              (type-grouping (assoc-get type exceptions '()))
  86              (default-rule (and (null? type-grouping)
  87                                 (larger-setting type exceptions)))
  88              (default-grouping (and default-rule (cdr default-rule)))
  89              (default-beat-length (and default-rule (car default-rule)))
  90              (exception-grouping (if (null? type-grouping)
  91                                      default-grouping
  92                                      type-grouping))
  93              (grouping-moment (if (null? type-grouping)
  94                                   default-beat-length
  95                                   type))
  96              (exception-moments (and exception-grouping
  97                                      (ending-moments
  98                                       exception-grouping 0 grouping-moment))))
  99
 100         (if (= dir START)
 101             ;; Start rules -- #t if beam is allowed to start
 102             (or beam-half-measure ;; Start anywhere, but option for mid-measure
 103                 (not (= (+ pos pos) measure-length))
 104                 (not (= 3 (car time-signature-fraction))) ;; in triple meter
 105                 (not (= (denominator type) ;; when the beamed note is 1/6 of a measure
 106                         (* 2 (cdr time-signature-fraction)))))
 107             ;; End rules -- #t if beam is required to end
 108             (or (zero? pos) ;; end at measure beginning
 109                 (if exception-grouping
 110                     (beat-end? pos exception-moments) ;; check exception rule
 111                     (beat-end? pos beat-endings))))))) ;; no exception, so check beat ending
 112
 113
 114 (define-public (extract-beam-exceptions music)
 115   "Creates a value useful for setting @code{beamExceptions} from @var{music}."
 116   (define (car> a b) (> (car a) (car b)))
 117   (define (beatify lst)
 118     ;; takes a collection of end points, sorts them, and returns the
 119     ;; non-zero differences as beaming pattern
 120     (let ((s (sort lst <)))
 121       (remove zero?
 122               (map - s (cons 0 s)))))
 123   ;; TODO: let this do something useful with simultaneous music.
 124   (let loop
 125       ((lst (extract-typed-music (unfold-repeats-fully (event-chord-reduce music))
 126                                  '(rhythmic-event bar-check)))
 127        (pos 0) (res '()))
 128     (cond ((null? lst)
 129            (list
 130             (cons 'end
 131                   (map
 132                    (lambda (l)
 133                      (cons (cons (numerator (car l)) (denominator (car l)))
 134                            (beatify (cdr l))))
 135                    (sort res car>)))))
 136           ((music-is-of-type? (car lst) 'bar-check)
 137            (loop (cdr lst) 0 res))
 138           ;; Have rhythmic event.
 139           ((any
 140             (lambda (art)
 141               (and (music-is-of-type? art 'beam-event)
 142                    (= (ly:music-property art 'span-direction START) STOP)))
 143             (ly:music-property (car lst) 'articulations))
 144            (let* ((dur (ly:music-property (car lst) 'duration))
 145                   (len (if (ly:duration? dur) (duration-length dur) 0))
 146                   (pos (+ pos len))
 147                   (ass (assoc len res)))
 148              (cond ((or (zero? len) (not (integer? (/ pos len))))
 149                     (ly:warning (car lst) (_ "Beam end fits no pattern"))
 150                     (loop (cdr lst) pos res))
 151                    (ass
 152                     (set-cdr! ass (cons (/ pos len) (cdr ass)))
 153                     (loop (cdr lst) pos res))
 154                    (else
 155                     (loop (cdr lst) pos (cons (list len (/ pos len)) res))))))
 156           (else
 157            (let* ((dur (ly:music-property (car lst) 'duration))
 158                   (len (if (ly:duration? dur) (duration-length dur) 0)))
 159              (loop (cdr lst)
 160                    (+ pos len)
 161                    res))))))