*** empty log message ***

[lilypond.git] / scm / beam.scm

diff --git a/scm/beam.scm b/scm/beam.scm
index ab79154115a50b1efca047dc211b4f737441f3e9..7ab4637d4194533e0c3d060fc1eb2947bef1b449 100644 (file)
--- a/scm/beam.scm
+++ b/scm/beam.scm
@@ -68,8 +68,8 @@
   (let*
       ((posns (ly:grob-property beam 'positions))
        (thick (ly:grob-property beam 'thickness))
-       (paper (ly:grob-paper beam))
-       (lthick (ly:output-def-lookup paper 'linethickness))
+       (layout (ly:grob-layout beam))
+       (lthick (ly:output-def-lookup layout 'linethickness))
        (staff-thick lthick) ; fixme.
        (quant->coord (lambda (p q)
                       (if (= 2 (abs q))
@@ -81,10 +81,34 @@
     
     (if (or (not (almost-equal want-l (car posns)))
            (not (almost-equal want-r (cdr posns))))
-       (ly:warn
-        (format "Error in beam quanting found. Want (~S,~S) found (~S)."
-                want-l want-r posns
-                )))))
+       (begin
+         (ly:warn
+           "Error in beam quanting found. Want (~S,~S) found (~S)."
+                  want-l want-r posns )
+         (set! (ly:grob-property beam 'quant-score)
+               (format "(~S,~S)" want-l want-r)))
+       (set! (ly:grob-property beam 'quant-score) "")
+
+       
+         )))
+(define ((check-beam-slope-sign comparison) beam)
+  "Check whether the slope of BEAM is correct wrt. COMPARISON."
+  (let*
+      ((posns (ly:grob-property beam 'positions))
+       (slope-sign (- (cdr posns) (car posns)))
+       (correct (comparison slope-sign 0)))
+
+    
+    (if (not correct)
+       (begin
+         (ly:warn "Error in beam quanting found. Want ~S 0 found ~S."
+                  (procedure-name comparison) slope-sign)
+         (set! (ly:grob-property beam 'quant-score)
+               (format "~S 0" (procedure-name comparison) )))
+       (set! (ly:grob-property beam 'quant-score) "")
+
+       
+       )))
                 
 (define-public (check-quant-callbacks l r)
   (list Beam::least_squares
@@ -95,4 +119,14 @@
     (check-beam-quant l r)
     ))
 
+                
+(define-public (check-slope-callbacks comparison)
+  (list Beam::least_squares
+    Beam::check_concave
+    Beam::slope_damping
+    Beam::shift_region_to_valid
+    Beam::quanting
+    (check-beam-slope-sign comparison)
+    ))
+