From: David Kastrup <dak@gnu.org>
Date: Thu, 28 Nov 2013 14:24:17 +0000 (+0100)
Subject: Issue 3682/1: Implement \beamExceptions function fishing exceptions from beamed music.
X-Git-Tag: release/2.19.0-1~110
X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=953c46d541f9aa93571f95e7d51f94a1241216ef;p=lilypond.git

Issue 3682/1: Implement \beamExceptions function fishing exceptions from beamed music.
---

diff --git a/ly/music-functions-init.ly b/ly/music-functions-init.ly
index bf738074cd..bb577e28b5 100644
--- a/ly/music-functions-init.ly
+++ b/ly/music-functions-init.ly
@@ -221,6 +221,14 @@ barNumberCheck =
 					 "Barcheck failed got ~a expect ~a"
 					 cbn n))))))
 
+beamExceptions =
+#(define-scheme-function (parser location music) (ly:music?)
+   (_i "Extract a value suitable for setting
+@code{Timing.beamExceptions} from the given pattern with explicit
+beams in @var{music}.  A bar check @code{|} has to be used between
+bars of patterns in order to reset the timing.")
+   (extract-beam-exceptions music))
+
 bendAfter =
 #(define-event-function (parser location delta) (real?)
    (_i "Create a fall or doit of pitch interval @var{delta}.")
diff --git a/scm/auto-beam.scm b/scm/auto-beam.scm
index 14e0209675..b863e5c5a7 100644
--- a/scm/auto-beam.scm
+++ b/scm/auto-beam.scm
@@ -118,3 +118,52 @@
                 (if (null? exception-grouping)
                     (beat-end? pos beat-endings) ;; no exception, so check beat ending
                     (member pos exception-moments))))))) ;; check exception rule
+
+(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 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))))))