* scm/define-markup-commands.scm (whiteout): do not force

[lilypond.git] / scm / paper-system.scm

diff --git a/scm/paper-system.scm b/scm/paper-system.scm
index d414285d9df3d75a5dde138f8905343f5f7164a7..43711a4ee1c94ea7536c4910281b766842ff60c6 100644 (file)
--- a/scm/paper-system.scm
+++ b/scm/paper-system.scm
@@ -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))))))