[patch] annotations

[Nicolas Sceaux]

Hi,

Here is a patch which aim at displaying spacing annotations in a little
more readable fashion.

A question however: is there a reason why the whiteout markup command
forces the foreground color to black? This does not seem necessary at
first sight, but maybe this is useful in some context...

May I apply?

nicolas

Index: ChangeLog
===================================================================
RCS file: /cvsroot/lilypond/lilypond/ChangeLog,v
retrieving revision 1.5017
diff -u -r1.5017 ChangeLog
--- ChangeLog   27 May 2006 17:42:05 -0000      1.5017
+++ ChangeLog   28 May 2006 11:28:42 -0000
@@ -1,3 +1,21 @@
+2006-05-28  Nicolas Sceaux  <address@hidden>
+
+       * scm/define-markup-commands.scm (whiteout): do not force
+       foreground color of argument markup to black.
+
+       * scm/stencil.scm (annotate-y-interval): put arrow dimension at
+       the left of the arrow, instead of below the arrow name, so that,
+       when two little arrows are vertically stacked, their dimensions
+       and name should not overlap. Add a color key parameter.
+
+       * scm/paper-system.scm (paper-system-annotate): Annotate
+       next-space+next-padding instead of next-space. Annotate space
+       between next-padding and next-space+padding, respectively, and
+       following system extent and refpoint-Y-extent. Use colors.
+
+       * scm/page.scm (annotate-page): translate annotations slightly to
+       the right.
+
 2006-05-27  Han-Wen Nienhuys  <address@hidden>
 
        * scripts/lilypond-book.py (Lilypond_file_snippet.ly): strip
Index: scm/define-markup-commands.scm
===================================================================
RCS file: /cvsroot/lilypond/lilypond/scm/define-markup-commands.scm,v
retrieving revision 1.147
diff -u -r1.147 define-markup-commands.scm
--- scm/define-markup-commands.scm      14 May 2006 14:06:37 -0000      1.147
+++ scm/define-markup-commands.scm      28 May 2006 11:28:46 -0000
@@ -126,8 +126,7 @@
 
 (define-markup-command (whiteout layout props arg) (markup?)
   "Provide a white underground for @var{arg}"
-  (let* ((stil (interpret-markup layout props
-                                (make-with-color-markup black arg)))
+  (let* ((stil (interpret-markup layout props arg))
         (white
          (interpret-markup layout props
                            (make-with-color-markup
Index: scm/page.scm
===================================================================
RCS file: /cvsroot/lilypond/lilypond/scm/page.scm,v
retrieving revision 1.10
diff -u -r1.10 page.scm
--- scm/page.scm        28 Feb 2006 18:42:27 -0000      1.10
+++ scm/page.scm        28 May 2006 11:28:47 -0000
@@ -85,37 +85,31 @@
        (page-property page 'configuration))))
 
 (define (annotate-page layout stencil)
-  (let*
-      ((top-margin (ly:output-def-lookup layout 'top-margin))
-       (paper-height (ly:output-def-lookup layout 'paper-height))
-       (bottom-margin (ly:output-def-lookup layout 'bottom-margin))
-       (add-stencil (lambda (y)
-                     (set! stencil
-                           (ly:stencil-add stencil y))
-                     )))
-
+  (let ((top-margin (ly:output-def-lookup layout 'top-margin))
+       (paper-height (ly:output-def-lookup layout 'paper-height))
+       (bottom-margin (ly:output-def-lookup layout 'bottom-margin))
+       (add-stencil (lambda (y)
+                      (set! stencil
+                            (ly:stencil-add stencil
+                                            (ly:stencil-translate-axis y 6 
X))))))
     (add-stencil
      (ly:stencil-translate-axis 
       (annotate-y-interval layout "paper-height"
                           (cons (- paper-height) 0)
                           #t)
       1 X))
-    
-
     (add-stencil
      (ly:stencil-translate-axis 
       (annotate-y-interval layout "top-margin"
                           (cons (- top-margin) 0)
                           #t)
       2 X))
-    
     (add-stencil
      (ly:stencil-translate-axis 
       (annotate-y-interval layout "bottom-margin"
                           (cons (- paper-height) (- bottom-margin 
paper-height))
                           #t)
       2 X))
-    
     stencil))
 
 (define (annotate-space-left page)
@@ -324,8 +318,10 @@
            (ly:output-def-lookup layout 'annotatesystems #f))
 
        (begin
-         (for-each (lambda (sys) (paper-system-annotate sys layout))
-                   lines)
+         (for-each (lambda (sys next-sys)
+                     (paper-system-annotate sys next-sys layout))
+                   lines
+                   (append (cdr lines) (list #f)))
          (paper-system-annotate-last (car (last-pair lines)) layout)))
     
     (set! page-stencil (ly:stencil-combine-at-edge
Index: scm/paper-system.scm
===================================================================
RCS file: /cvsroot/lilypond/lilypond/scm/paper-system.scm,v
retrieving revision 1.4
diff -u -r1.4 paper-system.scm
--- scm/paper-system.scm        27 May 2006 01:07:55 -0000      1.4
+++ scm/paper-system.scm        28 May 2006 11:28:47 -0000
@@ -49,57 +49,89 @@
          stencil)
   ))
   
-(define-public (paper-system-annotate system layout)
+(define-public (paper-system-annotate system next-system layout)
   "Add arrows and texts to indicate which lengths are set."
-  
-  (let*
-      ((annotations (ly:make-stencil '() (cons 0 2) (cons 0 0)))
-       (append-stencil
-       (lambda (a b)
-         (ly:stencil-combine-at-edge a X RIGHT b 0.5 0)))
-
-       (annotate-property
-       (lambda (name extent is-length?)
-         (set! annotations
-               (append-stencil annotations
-                               (annotate-y-interval layout
-                                                    name extent is-length?)))))
-
-       (bbox-extent (paper-system-extent system Y))
-       (refp-extent (ly:prob-property system 'refpoint-Y-extent))
-       (next-space (ly:prob-property system 'next-space
-                                            (ly:output-def-lookup layout 
'between-system-space)
-                                            ))
-       (next-padding (ly:prob-property system 'next-padding
-                                              (ly:output-def-lookup layout 
'between-system-padding)
-                                              ))
-       )
-
-    (if (number-pair? bbox-extent)
-       (begin
-         (annotate-property  "Y-extent"
-                              bbox-extent #f)
-         (annotate-property  "next-padding"
-                            (interval-translate (cons (- next-padding) 0) (car 
bbox-extent))
-                            #t)))
-    
-    ;; titles don't have a refpoint-Y-extent.
-    (if (number-pair? refp-extent)
-       (begin
-         (annotate-property "refpoint-Y-extent"
-                            refp-extent #f)
-       
-         (annotate-property "next-space"
-                            (interval-translate (cons (- next-space) 0) (car 
refp-extent))
-                      #t)))
-
+  (let* ((annotations (list))
+        (annotate-extent-and-space
+         (lambda (extent-accessor next-space
+                                  extent-name next-space-name after-space-name)
+           (let* ((extent-annotations (list))
+                  (this-extent (extent-accessor system))
+                  (next-extent (and next-system (extent-accessor next-system)))
+                  (push-annotation (lambda (stil)
+                                     (set! extent-annotations
+                                           (cons stil extent-annotations))))
+                  (color (if (paper-system-title? system) darkblue blue))
+                  (space-color (if (paper-system-title? system) darkred red)))
+             (if (and (number-pair? this-extent)
+                      (not (= (interval-start this-extent)
+                              (interval-end this-extent))))
+                 (push-annotation (annotate-y-interval
+                                   layout extent-name this-extent #f
+                                   #:color color)))
+             (if next-system
+                 (push-annotation (annotate-y-interval
+                                   layout next-space-name
+                                   (interval-translate (cons (- next-space) 0)
+                                                       (if (number-pair? 
this-extent)
+                                                           (interval-start 
this-extent)
+                                                           0))
+                                   #t
+                                   #:color color)))
+             (if (and next-system
+                      (number-pair? this-extent)
+                      (number-pair? next-extent))
+                 (let ((space-after
+                        (- (+ (ly:prob-property next-system 'Y-offset)
+                              (interval-start this-extent))
+                           (ly:prob-property system 'Y-offset)
+                           (interval-end next-extent)
+                           next-space)))
+                   (if (> space-after 0.01)
+                       (push-annotation (annotate-y-interval
+                                         layout
+                                         after-space-name
+                                         (interval-translate
+                                          (cons (- space-after) 0)
+                                          (- (interval-start this-extent)
+                                             next-space))
+                                         #t
+                                         #:color space-color)))))
+             (if (not (null? extent-annotations))
+                 (set! annotations
+                       (stack-stencils X RIGHT 0.5
+                                       (list annotations
+                                             (ly:make-stencil '() (cons 0 1) 
(cons 0 0))
+                                             (apply ly:stencil-add
+                                                    extent-annotations)))))))))
+    (let ((next-space (ly:prob-property
+                      system 'next-space
+                      (cond ((and next-system
+                                  (paper-system-title? system)
+                                  (paper-system-title? next-system))
+                             (ly:output-def-lookup layout 
'between-title-space))
+                            ((paper-system-title? system)
+                             (ly:output-def-lookup layout 'after-title-space))
+                            ((and next-system
+                                  (paper-system-title? next-system))
+                             (ly:output-def-lookup layout 'before-title-space))
+                            (else
+                             (ly:output-def-lookup layout 
'between-system-space)))))
+         (next-padding (ly:prob-property
+                        system 'next-padding
+                        (ly:output-def-lookup layout 
'between-system-padding))))
+      (annotate-extent-and-space (lambda (sys)
+                                  (paper-system-extent sys Y))
+                                next-padding
+                                "Y-extent" "next-padding" "space after 
next-padding")
+      (annotate-extent-and-space paper-system-staff-extents
+                                (+ next-space next-padding)
+                                "refpoint-Y-extent" "next-space+padding"
+                                "space after next-space+padding"))
     (set! (ly:prob-property system 'stencil)
          (ly:stencil-add
           (ly:prob-property system 'stencil)
           (ly:make-stencil
            (ly:stencil-expr annotations)
            (ly:stencil-extent empty-stencil X)
-           (ly:stencil-extent empty-stencil Y)
-           )))
-    
-    ))
+           (ly:stencil-extent empty-stencil Y))))))
Index: scm/stencil.scm
===================================================================
RCS file: /cvsroot/lilypond/lilypond/scm/stencil.scm,v
retrieving revision 1.30
diff -u -r1.30 stencil.scm
--- scm/stencil.scm     27 May 2006 01:07:55 -0000      1.30
+++ scm/stencil.scm     28 May 2006 11:28:47 -0000
@@ -179,52 +179,48 @@
 ;; spacing variables 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define-public (annotate-y-interval layout name extent is-length)
-  (let*
-      ((text-props (cons
-                   '((font-size . -3)
-                     (font-family . typewriter))
-                   (layout-extract-page-properties layout)))
-       (annotation #f)
-       )
-
+(define*-public (annotate-y-interval layout name extent is-length
+                                     #:key (color darkblue))
+  (let ((text-props (cons '((font-size . -3)
+                           (font-family . typewriter))
+                         (layout-extract-page-properties layout)))
+       (annotation #f))
+    (define (center-stencil-on-extent stil)
+      (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER)
+                            (cons 0 (interval-center extent))))
     ;; do something sensible for 0,0 intervals. 
     (set! extent (interval-widen extent 0.001))
     (if (not (interval-sane? extent))
-       (set! annotation (interpret-markup layout text-props
-                                          (make-simple-markup (format "~a: 
NaN/inf" name))))
-       (let*
-           ((text-stencil (interpret-markup
-                           layout text-props
-                           (make-column-markup
-                            (list
-                             (make-whiteout-markup (make-simple-markup name))
-                             (make-whiteout-markup
-                              (make-simple-markup
-                               (cond
-                                ((interval-empty? extent) "empty")
-                                (is-length (format "~$" (interval-length 
extent)))
-                                (else
-                                 (format "(~$,~$)" (car extent)
-                                         (cdr extent))))))))))
-            (arrows
-             (ly:stencil-translate-axis 
-              (dimension-arrows (cons 0 (interval-length extent)))
-              (interval-start extent) Y)))
-         
+       (set! annotation (interpret-markup
+                         layout text-props
+                         (make-simple-markup (format "~a: NaN/inf" name))))
+       (let ((text-stencil (interpret-markup
+                            layout text-props
+                             (markup #:whiteout #:simple name)))
+              (dim-stencil (interpret-markup
+                            layout text-props
+                            (markup #:whiteout
+                                    #:simple (cond
+                                              ((interval-empty? extent)
+                                               (format "empty"))
+                                              (is-length
+                                               (format "~$" (interval-length 
extent)))
+                                              (else
+                                               (format "(~$,~$)"
+                                                       (car extent) (cdr 
extent)))))))
+             (arrows (ly:stencil-translate-axis 
+                      (dimension-arrows (cons 0 (interval-length extent)))
+                      (interval-start extent) Y)))
          (set! annotation
-               (ly:stencil-aligned-to text-stencil Y CENTER))
-         
-         (set! annotation (ly:stencil-translate
-                           annotation
-                           (cons 0 (interval-center extent))))
-         
-
+                (center-stencil-on-extent text-stencil))
          (set! annotation
                (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5 0))
-
          (set! annotation
-               (ly:make-stencil (ly:stencil-expr annotation)
+               (ly:stencil-combine-at-edge annotation X LEFT
+                                            (center-stencil-on-extent 
dim-stencil)
+                                            0.5 0))
+         (set! annotation
+               (ly:make-stencil (list 'color color (ly:stencil-expr 
annotation))
                                 (ly:stencil-extent annotation X)
                                 (cons 10000 -10000)))))
     annotation))