X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fauto-beam.scm;h=9ba08705ef0102cab09683c8e2747411f7a23704;hb=HEAD;hp=43ec64e9b4e82e1a2b431d36935f16b9ec3a0209;hpb=bc95f4434f760d41191341ab4508b2064eb19025;p=lilypond.git diff --git a/scm/auto-beam.scm b/scm/auto-beam.scm index 43ec64e9b4..9ba08705ef 100644 --- a/scm/auto-beam.scm +++ b/scm/auto-beam.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; Copyright (C) 2000--2010 Jan Nieuwenhuizen +;;;; Copyright (C) 2000--2015 Jan Nieuwenhuizen ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -15,84 +15,149 @@ ;;;; You should have received a copy of the GNU General Public License ;;;; along with LilyPond. If not, see . -;; Determine end moment for auto beaming (or begin moment, but mostly -;; 0== anywhere). We only consider the current time signature. -;; In order of decreasing priority: +;; Determine whether an auto beam should be extended to the right +;; of the current stem. We start anywhere, except mid-measure in +;; 3/4 time. We end according to the follwing rules, in order of +;; decreasing priority: ;; ;; 1. end -;; 2. end * -;; 3. if 1-2 not specified, begin anywhere, end at beatLength intervals +;; 2. end +;; 3. if 1-2 not specified, end at beatStructure intervals ;; ;; Rationale: ;; ;; [user override] ;; 1. override for specific duration type -;; 2. override for all duration types in a time signature. +;; 2. overrides apply to shorter durations ;; -;; defined in scm/beam-settings.scm: +;; defined in scm/time-signature-settings.scm: ;; 1. Default grouping for common time signatures -;; 2. exceptions for specific time signature, for specific duration type - (define-public (default-auto-beam-check context dir measure-pos test-beam) (define (get name default) (let ((value (ly:context-property context name))) (if (not (null? value)) value default))) - (define (ending-moments group-list start-beat beat-length) - (if (null? group-list) - '() - (let ((new-start (+ start-beat (car group-list)))) - (cons (ly:moment-mul (ly:make-moment new-start 1) beat-length) - (ending-moments (cdr group-list) new-start beat-length))))) + (define (ending-moments group-list base-length) + (let ((beat 0)) + (map-in-order (lambda (x) + (set! beat (+ beat x)) + (* base-length beat)) + group-list))) + + (define (larger-setting type sorted-alist) + (assoc type sorted-alist <=)) + + (define (beat-end? moment beat-endings) + (pair? (memv moment beat-endings))) ;; member returns a list if found, not #t ;; Start of actual auto-beam test routine ;; ;; ;; Don't start auto beams on grace notes - (if (and (!= (ly:moment-grace-numerator (ly:context-now context)) 0) - (= dir START)) - #f - (if (= dir START) - ;; start anywhere is currently implemented - #t - (let* ((beat-length (get 'beatLength (ly:make-moment 1 4))) - (measure-length (get 'measureLength (ly:make-moment 1 1))) - (time-signature-fraction - (get 'timeSignatureFraction '(4 . 4))) - (settings (get 'beamSettings '())) - (function (if (= dir START) 'begin 'end)) - (type (cons (ly:moment-main-numerator test-beam) - (ly:moment-main-denominator test-beam))) - (pos (if (>= (ly:moment-main-numerator measure-pos) 0) - measure-pos - (ly:moment-add measure-length measure-pos))) - (type-grouping (ly:beam-grouping - settings - time-signature-fraction - function + (and (or (zero? (ly:moment-grace (ly:context-now context))) + (!= dir START)) + (let* ((base-length (cond ((get 'baseMoment #f) => ly:moment-main) + (else 1/4))) + (measure-length (cond ((get 'measureLength #f) => ly:moment-main) + (else 1))) + (time-signature-fraction + (get 'timeSignatureFraction '(4 . 4))) + (beat-structure (get 'beatStructure '(1 1 1 1))) + (beat-endings (ending-moments beat-structure base-length)) + (exceptions (sort (map + (lambda (a) + (if (pair? (car a)) + (cons (/ (caar a) (cdar a)) + (cdr a)) + a)) + (assoc-get 'end + (get 'beamExceptions '()) + '())) + car<)) + (function (if (= dir START) 'begin 'end)) + (beam-half-measure (get 'beamHalfMeasure #t)) + (type (ly:moment-main test-beam)) + (non-grace (ly:moment-main measure-pos)) + (pos (if (negative? non-grace) + (+ measure-length non-grace) + non-grace)) + (type-grouping (assoc-get type exceptions '())) + (default-rule (and (null? type-grouping) + (larger-setting type exceptions))) + (default-grouping (and default-rule (cdr default-rule))) + (default-beat-length (and default-rule (car default-rule))) + (exception-grouping (if (null? type-grouping) + default-grouping + type-grouping)) + (grouping-moment (if (null? type-grouping) + default-beat-length type)) - (default-grouping (ly:beam-grouping - settings - time-signature-fraction - function - '*)) - (beat-grouping (if (null? type-grouping) - default-grouping - type-grouping)) - (grouping-moment (if (null? type-grouping) - beat-length - test-beam)) - (grouping-moments (ending-moments - beat-grouping 0 grouping-moment))) - (if (null? beat-grouping) - ;; no rule applies, so end at beatLength - (= (ly:moment-main-denominator - (ly:moment-div pos beat-length)) 1) - ;; otherwise, end at beginning of measure or - ;; at specified moment - (or - ;; start/end at beginning of measure - (= (ly:moment-main-numerator pos) 0) - ;; end if measure-pos matches a specified ending moment - (member pos grouping-moments))))))) + (exception-moments (and exception-grouping + (ending-moments + exception-grouping grouping-moment)))) + + (if (= dir START) + ;; Start rules -- #t if beam is allowed to start + (or beam-half-measure ;; Start anywhere, but option for mid-measure + (not (= (+ pos pos) measure-length)) + (not (= 3 (car time-signature-fraction))) ;; in triple meter + (not (= (denominator type) ;; when the beamed note is 1/6 of a measure + (* 2 (cdr time-signature-fraction))))) + ;; End rules -- #t if beam is required to end + (or (zero? pos) ;; end at measure beginning + (if exception-grouping + (beat-end? pos exception-moments) ;; check exception rule + (beat-end? pos beat-endings))))))) ;; no exception, so check beat ending + + +(define-public (extract-beam-exceptions music) + "Creates a value useful for setting @code{beamExceptions} from @var{music}." + (define (car> a b) (> (car a) (car b))) + (define (beatify! lst) + ;; takes a collection of end points, sorts them, and returns the + ;; non-zero differences as beaming pattern + (let ((s (sort-list! lst <))) + (remove! zero? + (map - s (cons 0 s))))) + (let ((res '())) + (let analyze ((m (unfold-repeats-fully (event-chord-reduce music))) + (pos 0)) + ;; enter beam ends from m starting at pos into res, return new pos + (cond ((music-is-of-type? m 'bar-check) 0) + ((music-is-of-type? m 'simultaneous-music) + (fold (lambda (m prev) (max (analyze m pos) prev)) + pos + (ly:music-property m 'elements))) + ((not (music-is-of-type? m 'rhythmic-event)) + (let ((elt (ly:music-property m 'element))) + (fold analyze + (if (ly:music? elt) (analyze elt pos) pos) + (ly:music-property m 'elements)))) + ;; Have rhythmic event. + ((any + (lambda (art) + (and (music-is-of-type? art 'beam-event) + (= (ly:music-property art 'span-direction START) STOP))) + (ly:music-property m 'articulations)) + (let* ((len (duration-length (ly:music-property m 'duration))) + (pos (+ pos len)) + (ass (assv len res))) + (cond ((or (zero? len) (not (integer? (/ pos len)))) + (ly:warning m (_ "Beam end fits no pattern"))) + (ass + (set-cdr! ass (cons (/ pos len) (cdr ass)))) + (else + (set! res (cons (list len (/ pos len)) res)))) + pos)) + (else + (+ pos (duration-length (ly:music-property m 'duration)))))) + + ;; takes the output from the loop, generates actual beam exceptions + (list + (cons 'end + (map! + (lambda (l) + (cons (car l) + (beatify! (cdr l)))) + (sort-list! res car>))))))