scm/auto-beam.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2000--2014 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-list! lst <)))
 121       (remove! zero?
 122                (map - s (cons 0 s)))))
 123   (let ((res '()))
 124     (let analyze ((m (unfold-repeats-fully (event-chord-reduce music)))
 125                   (pos 0))
 126       ;; enter beam ends from m starting at pos into res, return new pos
 127       (cond ((music-is-of-type? m 'bar-check) 0)
 128             ((music-is-of-type? m 'simultaneous-music)
 129              (fold (lambda (m prev) (max (analyze m pos) prev))
 130                    pos
 131                    (ly:music-property m 'elements)))
 132             ((not (music-is-of-type? m 'rhythmic-event))
 133              (let ((elt (ly:music-property m 'element)))
 134                (fold analyze
 135                      (if (ly:music? elt) (analyze elt pos) pos)
 136                      (ly:music-property m 'elements))))
 137             ;; Have rhythmic event.
 138             ((any
 139               (lambda (art)
 140                 (and (music-is-of-type? art 'beam-event)
 141                      (= (ly:music-property art 'span-direction START) STOP)))
 142               (ly:music-property m 'articulations))
 143              (let* ((len (duration-length (ly:music-property m 'duration)))
 144                     (pos (+ pos len))
 145                     (ass (assv len res)))
 146                (cond ((or (zero? len) (not (integer? (/ pos len))))
 147                       (ly:warning m (_ "Beam end fits no pattern")))
 148                      (ass
 149                       (set-cdr! ass (cons (/ pos len) (cdr ass))))
 150                      (else
 151                       (set! res (cons (list len (/ pos len)) res))))
 152                pos))
 153             (else
 154              (+ pos (duration-length (ly:music-property m 'duration))))))
 155
 156     ;; takes the output from the loop, generates actual beam exceptions
 157     (list
 158      (cons 'end
 159            (map!
 160             (lambda (l)
 161               (cons (car l)
 162                     (beatify! (cdr l))))
 163             (sort-list! res car>))))))