X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fauto-beam.scm;h=9ba08705ef0102cab09683c8e2747411f7a23704;hb=90e4d7057f3857da049dfda3d130017d4719bd6b;hp=70f6b5f1a008eeab9aa26550435838bf011fef76;hpb=80072e19b47514914cb095cbe974b9a180cd295e;p=lilypond.git

diff --git a/scm/auto-beam.scm b/scm/auto-beam.scm
index 70f6b5f1a0..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--2012 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Copyright (C) 2000--2015 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -38,12 +38,12 @@
     (let ((value (ly:context-property context name)))
       (if (not (null? value)) value default)))
 
-  (define (ending-moments group-list start-beat base-length)
-    (if (null? group-list)
-        '()
-        (let ((new-start (+ start-beat (car group-list))))
-          (cons (* new-start base-length)
-                (ending-moments (cdr group-list) new-start base-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 <=))
@@ -64,7 +64,7 @@
              (time-signature-fraction
               (get 'timeSignatureFraction '(4 . 4)))
              (beat-structure (get 'beatStructure '(1 1 1 1)))
-             (beat-endings (ending-moments beat-structure 0 base-length))
+             (beat-endings (ending-moments beat-structure base-length))
              (exceptions (sort (map
                                 (lambda (a)
                                   (if (pair? (car a))
@@ -95,7 +95,7 @@
                                   type))
              (exception-moments (and exception-grouping
                                      (ending-moments
-                                      exception-grouping 0 grouping-moment))))
+                                      exception-grouping grouping-moment))))
 
         (if (= dir START)
             ;; Start rules -- #t if beam is allowed to start
@@ -114,48 +114,50 @@
 (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)
+  (define (beatify! lst)
     ;; takes a collection of end points, sorts them, and returns the
     ;; non-zero differences as beaming pattern
-    (let ((s (sort lst <)))
-      (remove zero?
-              (map - s (cons 0 s)))))
-  ;; TODO: let this do something useful with simultaneous music.
-  (let loop
-      ((lst (extract-typed-music (unfold-repeats-fully (event-chord-reduce music))
-                                 '(rhythmic-event bar-check)))
-       (pos 0) (res '()))
-    (cond ((null? lst)
-           (list
-            (cons 'end
-                  (map
-                   (lambda (l)
-                     (cons (cons (numerator (car l)) (denominator (car l)))
-                           (beatify (cdr l))))
-                   (sort res car>)))))
-          ((music-is-of-type? (car lst) 'bar-check)
-           (loop (cdr lst) 0 res))
-          ;; 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 (car lst) 'articulations))
-           (let* ((dur (ly:music-property (car lst) 'duration))
-                  (len (if (ly:duration? dur) (duration-length dur) 0))
-                  (pos (+ pos len))
-                  (ass (assoc len res)))
-             (cond ((or (zero? len) (not (integer? (/ pos len))))
-                    (ly:warning (car lst) (_ "Beam end fits no pattern"))
-                    (loop (cdr lst) pos res))
-                   (ass
-                    (set-cdr! ass (cons (/ pos len) (cdr ass)))
-                    (loop (cdr lst) pos res))
-                   (else
-                    (loop (cdr lst) pos (cons (list len (/ pos len)) res))))))
-          (else
-           (let* ((dur (ly:music-property (car lst) 'duration))
-                  (len (if (ly:duration? dur) (duration-length dur) 0)))
-             (loop (cdr lst)
-                   (+ pos len)
-                   res))))))
+    (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>))))))