X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fstencil.scm;fp=scm%2Fstencil.scm;h=64f48cc89df75604f2b1a47b0bf085d2a8624686;hb=941dff9d2a67080e0dd8474f1e70f0c72ace6424;hp=105f6f5893555deade31e7f9b5e5e97aed13d8ff;hpb=5a22d6233a39d3164e1ca043244794c268be4ad0;p=lilypond.git

diff --git a/scm/stencil.scm b/scm/stencil.scm
index 105f6f5893..64f48cc89d 100644
--- a/scm/stencil.scm
+++ b/scm/stencil.scm
@@ -1,11 +1,23 @@
-;;;; stencil.scm -- 
+;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
-;;;;  source file of the GNU LilyPond music typesetter
-;;;; 
-;;;; (c) 2003--2009 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; Copyright (C) 2003--2011 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;;
+;;;; LilyPond is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; LilyPond is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-public (stack-stencils axis dir padding stils)
-  "Stack stencils STILS in direction AXIS, DIR, using PADDING."
+  "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
+@var{padding}."
   (cond
    ((null? stils) empty-stencil)
    ((null? (cdr stils)) (car stils))
@@ -14,7 +26,8 @@
 	  padding))))
 
 (define-public (stack-stencils-padding-list axis dir padding stils)
-  "Stack stencils STILS in direction AXIS, DIR, using a list of PADDING."
+  "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
+a list of @var{padding}."
   (cond
    ((null? stils) empty-stencil)
    ((null? (cdr stils)) (car stils))
@@ -25,17 +38,17 @@
 	  (car padding)))))
 
 (define-public (centered-stencil stencil)
-  "Center stencil @var{stencil} in both the X and Y directions"
+  "Center stencil @var{stencil} in both the X and Y directions."
   (ly:stencil-aligned-to (ly:stencil-aligned-to stencil X CENTER) Y CENTER))
 
 (define-public (stack-lines dir padding baseline stils)
-  "Stack vertically with a baseline-skip."
+  "Stack vertically with a baseline skip."
   (define result empty-stencil)
   (define last-y #f)
   (do
       ((last-stencil #f (car p))
        (p stils (cdr p)))
-      
+
       ((null? p))
 
     (if (number? last-y)
@@ -45,9 +58,9 @@
 			     (* (- dir) (interval-bound (ly:stencil-extent (car p) Y) (- dir))))
 			  baseline))
 		 (y (+ last-y  (* dir dy))))
-	    
-			  
-	    
+
+
+
 	    (set! result
 		  (ly:stencil-add result (ly:stencil-translate-axis (car p) y Y)))
 	    (set! last-y y)))
@@ -56,27 +69,105 @@
 	  (set! result (car p)))))
 
   result)
-    
 
-(define-public (bracketify-stencil stil axis thick protusion padding)
-  "Add brackets around STIL, producing a new stencil."
+
+(define-public (bracketify-stencil stil axis thick protrusion padding)
+  "Add brackets around @var{stil}, producing a new stencil."
 
   (let* ((ext (ly:stencil-extent stil axis))
-	 (lb (ly:bracket axis ext thick (- protusion)))
-	 (rb (ly:bracket axis ext thick protusion)))
+	 (lb (ly:bracket axis ext thick protrusion))
+	 (rb (ly:bracket axis ext thick (- protrusion))))
     (set! stil
-	  (ly:stencil-combine-at-edge stil (other-axis axis) 1 lb padding))
+	  (ly:stencil-combine-at-edge stil (other-axis axis) 1 rb padding))
     (set! stil
-	  (ly:stencil-combine-at-edge stil (other-axis axis) -1 rb padding))
+	  (ly:stencil-combine-at-edge lb (other-axis axis) 1 stil padding))
     stil))
 
+(define (make-parenthesis-stencil
+	 y-extent half-thickness width angularity)
+  "Create a parenthesis stencil.
+@var{y-extent} is the Y extent of the markup inside the parenthesis.
+@var{half-thickness} is the half thickness of the parenthesis.
+@var{width} is the width of a parenthesis.
+The higher the value of number @var{angularity},
+the more angular the shape of the parenthesis."
+  (let* ((line-width 0.1)
+	 ;; Horizontal position of baseline that end points run through.
+	 (base-x
+	  (if (< width 0)
+	      (- width)
+	      0))
+         ;; X value farthest from baseline on outside  of curve
+         (outer-x (+ base-x width))
+         ;; X extent of bezier sandwich centerline curves
+         (x-extent (ordered-cons base-x outer-x))
+	 (bottom-y (interval-start y-extent))
+	 (top-y (interval-end y-extent))
+
+	 (lower-end-point (cons base-x bottom-y))
+	 (upper-end-point (cons base-x top-y))
+
+	 (outer-control-x (+ base-x (* 4/3 width)))
+	 (inner-control-x (+ outer-control-x
+			     (if (< width 0)
+				 half-thickness
+				 (- half-thickness))))
+
+	 ;; Vertical distance between a control point
+	 ;; and the end point it connects to.
+	 (offset-index (- (* 0.6 angularity) 0.8))
+	 (lower-control-y (interval-index y-extent offset-index))
+	 (upper-control-y (interval-index y-extent (- offset-index)))
+
+	 (lower-outer-control-point
+	  (cons outer-control-x lower-control-y))
+	 (upper-outer-control-point
+	  (cons outer-control-x upper-control-y))
+	 (upper-inner-control-point
+	  (cons inner-control-x upper-control-y))
+	 (lower-inner-control-point
+	  (cons inner-control-x lower-control-y)))
+
+    (ly:make-stencil
+     (list 'bezier-sandwich
+	   `(quote ,(list
+		     ;; Step 4: curve through inner control points
+		     ;; to lower end point.
+		     upper-inner-control-point
+		     lower-inner-control-point
+		     lower-end-point
+		     ;; Step 3: move to upper end point.
+		     upper-end-point
+		     ;; Step 2: curve through outer control points
+		     ;; to upper end point.
+		     lower-outer-control-point
+		     upper-outer-control-point
+		     upper-end-point
+		     ;; Step 1: move to lower end point.
+		     lower-end-point))
+	   line-width)
+     (interval-widen x-extent (/ line-width 2))
+     (interval-widen y-extent (/ line-width 2)))))
+
+(define-public (parenthesize-stencil
+		stencil half-thickness width angularity padding)
+  "Add parentheses around @var{stencil}, returning a new stencil."
+  (let* ((y-extent (ly:stencil-extent stencil Y))
+	 (lp (make-parenthesis-stencil
+	      y-extent half-thickness (- width) angularity))
+	 (rp (make-parenthesis-stencil
+	      y-extent half-thickness width angularity)))
+    (set! stencil (ly:stencil-combine-at-edge lp X RIGHT stencil padding))
+    (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT rp padding))
+    stencil))
+
 (define-public (make-line-stencil width startx starty endx endy)
-  "Make a line stencil of given linewidth and set its extents accordingly"
+  "Make a line stencil of given linewidth and set its extents accordingly."
   (let ((xext (cons (min startx endx) (max startx endx)))
         (yext (cons (min starty endy) (max starty endy))))
     (ly:make-stencil
       (list 'draw-line width startx starty endx endy)
-      ; Since the line has rounded edges, we have to / can safely add half the 
+      ; Since the line has rounded edges, we have to / can safely add half the
       ; width to all coordinates!
       (interval-widen xext (/ width 2))
       (interval-widen yext (/ width 2)))))
@@ -84,51 +175,259 @@
 
 (define-public (make-filled-box-stencil xext yext)
   "Make a filled box."
-  
+
   (ly:make-stencil
       (list 'round-filled-box (- (car xext)) (cdr xext)
                        (- (car yext)) (cdr yext) 0.0)
       xext yext))
 
 (define-public (make-circle-stencil radius thickness fill)
-  "Make a circle of radius @var{radius} and thickness @var{thickness}"
+  "Make a circle of radius @var{radius} and thickness @var{thickness}."
   (let*
       ((out-radius (+ radius (/ thickness 2.0))))
-    
+
   (ly:make-stencil
-   (list 'circle radius thickness fill) 
+   (list 'circle radius thickness fill)
    (cons (- out-radius) out-radius)
    (cons (- out-radius) out-radius))))
 
 (define-public (make-oval-stencil x-radius y-radius thickness fill)
-  "Make an oval from two Bezier curves, of x radius @var{x-radius}, 
-    y radius @code{y-radius},
-    and thickness @var{thickness} with fill defined by @code{fill}."
+  "Make an oval from two Bezier curves, of x@tie{}radius @var{x-radius},
+y@tie{}radius @code{y-radius}, and thickness @var{thickness} with fill
+defined by @code{fill}."
   (let*
-      ((x-out-radius (+ x-radius (/ thickness 2.0))) 
+      ((x-out-radius (+ x-radius (/ thickness 2.0)))
        (y-out-radius (+ y-radius (/ thickness 2.0))) )
-    
+
   (ly:make-stencil
-   (list 'oval x-radius y-radius thickness fill) 
+   (list 'oval x-radius y-radius thickness fill)
    (cons (- x-out-radius) x-out-radius)
    (cons (- y-out-radius) y-out-radius))))
 
+(define-public
+  (make-partial-ellipse-stencil
+    x-radius y-radius start-angle end-angle thick connect fill)
+
+  (define (make-radius-list x-radius y-radius)
+    (apply append
+           (map (lambda (adder)
+                  (map (lambda (quadrant)
+                         (cons (+ adder (car quadrant))
+                               (cdr quadrant)))
+                       `((0.0 . (,x-radius . 0.0))
+                         (,PI-OVER-TWO . (0.0 . ,y-radius))
+                         (,PI . (,(- x-radius) . 0.0))
+                         (,THREE-PI-OVER-TWO . (0.0 . ,(- y-radius))))))
+                `(0.0 ,TWO-PI))))
+
+  (define
+    (insert-in-ordered-list ordering-function value inlist cutl? cutr?)
+    (define
+      (helper ordering-function value left-list right-list cutl? cutr?)
+      (if (null? right-list)
+          (append
+            (if cutl? '() left-list)
+            (list value)
+            (if cutr? '() right-list))
+          (if (ordering-function value (car right-list))
+              (append
+                (if cutl? '() left-list)
+                (list value)
+                (if cutr? '() right-list))
+              (helper
+                ordering-function
+                value
+                (append left-list (list (car right-list)))
+                (cdr right-list)
+                cutl?
+                cutr?))))
+    (helper ordering-function value '() inlist cutl? cutr?))
+
+  (define (ordering-function-1 a b) (car< a b))
+
+  (define (ordering-function-2 a b) (car<= a b))
+
+  (define (min-max-crawler min-max side l)
+    (reduce min-max
+            (if (eq? min-max min) 100000 -100000)
+            (map (lambda (x) (side x)) l)))
+
+  (let*
+      ((x-out-radius (+ x-radius (/ thick 2.0)))
+       (y-out-radius (+ y-radius (/ thick 2.0)))
+       (new-end-angle (angle-0-2pi (degrees->radians end-angle)))
+       (end-radius (ellipse-radius x-out-radius y-out-radius new-end-angle))
+       (new-start-angle (angle-0-2pi (degrees->radians start-angle)))
+       (start-radius (ellipse-radius x-out-radius y-out-radius new-start-angle))
+       (radius-list (make-radius-list x-out-radius y-out-radius))
+       (rectangular-end-radius (polar->rectangular end-radius end-angle))
+       (rectangular-start-radius (polar->rectangular start-radius start-angle))
+       (new-end-angle
+         (if (<= new-end-angle new-start-angle)
+             (+ TWO-PI new-end-angle)
+             new-end-angle))
+       (possible-extrema
+         (insert-in-ordered-list
+           ordering-function-2
+           (cons new-end-angle rectangular-end-radius)
+           (insert-in-ordered-list
+             ordering-function-1
+             (cons new-start-angle rectangular-start-radius)
+             radius-list
+             #t
+             #f)
+           #f
+           #t)))
+    (ly:make-stencil
+      (list
+        'partial-ellipse
+        x-radius
+        y-radius
+        start-angle
+        end-angle
+        thick
+        connect
+        fill)
+      (cons (min-max-crawler min cadr possible-extrema)
+            (min-max-crawler max cadr possible-extrema))
+      (cons (min-max-crawler min cddr possible-extrema)
+            (min-max-crawler max cddr possible-extrema)))))
+
+(define (path-min-max origin pointlist)
+
+  (define (line-part-min-max x1 x2)
+    (list (min x1 x2) (max x1 x2)))
+
+  (define (bezier-part-min-max x1 x2 x3 x4)
+    ((lambda (x) (list (reduce min 10000 x) (reduce max -10000 x)))
+      (map
+	(lambda (x)
+	  (+ (* x1 (expt (- 1 x) 3))
+	     (+ (* 3 (* x2 (* (expt (- 1 x) 2) x)))
+		(+ (* 3 (* x3 (* (- 1 x) (expt x 2))))
+		   (* x4 (expt x 3))))))
+	(if (< (+ (expt x2 2) (+ (expt x3 2) (* x1 x4)))
+	       (+ (* x1 x3) (+ (* x2 x4) (* x2 x3))))
+	    (list 0.0 1.0)
+	    (filter
+	      (lambda (x) (and (>= x 0) (<= x 1)))
+	      (append
+		(list 0.0 1.0)
+		(map (lambda (op)
+		       (if (not (eqv? 0.0
+				      (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2)))))
+			   ;; Zeros of the bezier curve
+			   (/ (+ (- x1 (* 2 x2))
+				 (op x3
+				     (sqrt (- (+ (expt x2 2)
+						 (+ (expt x3 2) (* x1 x4)))
+					      (+ (* x1 x3)
+						 (+ (* x2 x4) (* x2 x3)))))))
+			      (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))
+			   ;; Apply L'hopital's rule to get the zeros if 0/0
+			   (* (op 0 1)
+			      (/ (/ (- x4 x3) 2)
+				 (sqrt (- (+ (* x2 x2)
+					     (+ (* x3 x3) (* x1 x4)))
+					  (+ (* x1 x3)
+					     (+ (* x2 x4) (* x2 x3)))))))))
+		     (list + -))))))))
+
+  (define (bezier-min-max x1 y1 x2 y2 x3 y3 x4 y4)
+    (map (lambda (x)
+	   (apply bezier-part-min-max x))
+	 `((,x1 ,x2 ,x3 ,x4) (,y1 ,y2 ,y3 ,y4))))
+
+  (define (line-min-max x1 y1 x2 y2)
+    (map (lambda (x)
+	   (apply line-part-min-max x))
+	 `((,x1 ,x2) (,y1 ,y2))))
+
+  ((lambda (x)
+     (list
+       (reduce min +inf.0 (map caar x))
+       (reduce max -inf.0 (map cadar x))
+       (reduce min +inf.0 (map caadr x))
+       (reduce max -inf.0 (map cadadr x))))
+    (map (lambda (x)
+	   (if (eq? (length x) 8)
+	       (apply bezier-min-max x)
+	       (apply line-min-max x)))
+	 (map (lambda (x y)
+		(append (list (cadr (reverse x)) (car (reverse x))) y))
+	      (append (list origin)
+		      (reverse (cdr (reverse pointlist)))) pointlist))))
+
+(define-public (make-connected-path-stencil pointlist thickness
+					    x-scale y-scale connect fill)
+  "Make a connected path described by the list @var{pointlist}, with
+thickness @var{thickness}, and scaled by @var{x-scale} in the X direction
+and @var{y-scale} in the Y direction.  @var{connect} and @var{fill} are
+boolean arguments that specify if the path should be connected or filled,
+respectively."
+
+  ;; paths using this routine are designed to begin at point '(0 . 0)
+  (let* ((origin (list 0 0))
+	 (boundlist (path-min-max origin pointlist))
+	 ;; modify pointlist to scale the coordinates
+	 (path (map (lambda (x)
+		      (apply
+			(if (eq? 6 (length x))
+			    (lambda (x1 x2 x3 x4 x5 x6)
+			      (list 'curveto
+				    (* x1 x-scale)
+				    (* x2 y-scale)
+				    (* x3 x-scale)
+				    (* x4 y-scale)
+				    (* x5 x-scale)
+				    (* x6 y-scale)))
+			    (lambda (x1 x2)
+			      (list 'lineto
+				    (* x1 x-scale)
+				    (* x2 y-scale))))
+			x))
+		    pointlist))
+	 ;; a path must begin with a `moveto'
+	 (prepend-origin (apply list (cons 'moveto origin) path))
+	 ;; if this path is connected, add closepath to the end
+	 (final-path (if connect
+			 (append prepend-origin (list 'closepath))
+			 prepend-origin))
+	 (command-list (fold-right append '() final-path)))
+
+  (ly:make-stencil
+    `(path ,thickness
+	   `(,@',command-list)
+	   'round
+	   'round
+	   ,(if fill #t #f))
+    (coord-translate
+      ((if (< x-scale 0) reverse-interval identity)
+        (cons (* x-scale (list-ref boundlist 0))
+              (* x-scale (list-ref boundlist 1))))
+        `(,(/ thickness -2) . ,(/ thickness 2)))
+    (coord-translate
+      ((if (< y-scale 0) reverse-interval identity)
+        (cons (* y-scale (list-ref boundlist 2))
+              (* y-scale (list-ref boundlist 3))))
+        `(,(/ thickness -2) . ,(/ thickness 2))))))
+
 (define-public (make-ellipse-stencil x-radius y-radius thickness fill)
-  "Make an ellipse of x radius @var{x-radius}, y radius @code{y-radius},
-    and thickness @var{thickness} with fill defined by @code{fill}."
+  "Make an ellipse of x@tie{}radius @var{x-radius}, y@tie{}radius
+@code{y-radius}, and thickness @var{thickness} with fill defined by
+@code{fill}."
   (let*
-      ((x-out-radius (+ x-radius (/ thickness 2.0))) 
+      ((x-out-radius (+ x-radius (/ thickness 2.0)))
        (y-out-radius (+ y-radius (/ thickness 2.0))) )
-    
+
   (ly:make-stencil
-   (list 'ellipse x-radius y-radius thickness fill) 
+   (list 'ellipse x-radius y-radius thickness fill)
    (cons (- x-out-radius) x-out-radius)
    (cons (- y-out-radius) y-out-radius))))
 
 (define-public (box-grob-stencil grob)
   "Make a box of exactly the extents of the grob.  The box precisely
-encloses the contents.
-"
+encloses the contents."
   (let* ((xext (ly:grob-extent grob grob 0))
 	 (yext (ly:grob-extent grob grob 1))
 	 (thick 0.01))
@@ -139,9 +438,9 @@ encloses the contents.
      (make-filled-box-stencil (cons (cdr xext) (+ (cdr xext) thick)) yext)
      (make-filled-box-stencil (cons (- (car xext) thick) (car xext)) yext))))
 
-;; TODO merge this and prev function. 
+;; TODO merge this and prev function.
 (define-public (box-stencil stencil thickness padding)
-  "Add a box around STENCIL, producing a new stencil."
+  "Add a box around @var{stencil}, producing a new stencil."
   (let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding))
 	 (y-ext (interval-widen (ly:stencil-extent stencil 1) padding))
 	 (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext))
@@ -149,16 +448,16 @@ encloses the contents.
 		  (interval-widen x-ext thickness) (cons 0 thickness))))
     (set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding))
     (set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding))
-    (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))  
+    (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))
     (set! stencil (ly:stencil-combine-at-edge stencil Y -1 x-rule 0.0))
     stencil))
 
 (define-public (circle-stencil stencil thickness padding)
-  "Add a circle around STENCIL, producing a new stencil."
+  "Add a circle around @var{stencil}, producing a new stencil."
   (let* ((x-ext (ly:stencil-extent stencil X))
 	 (y-ext (ly:stencil-extent stencil Y))
 	 (diameter (max (interval-length x-ext)
-                        (interval-length y-ext))) 
+                        (interval-length y-ext)))
 	 (radius (+ (/ diameter 2) padding thickness))
 	 (circle (make-circle-stencil radius thickness #f)))
 
@@ -170,8 +469,8 @@ encloses the contents.
 			    (interval-center y-ext))))))
 
 (define-public (oval-stencil stencil thickness x-padding y-padding)
-  "Add an oval around @code{stencil}, padded by the padding pair, 
-   producing a new stencil."
+  "Add an oval around @code{stencil}, padded by the padding pair,
+producing a new stencil."
   (let* ((x-ext (ly:stencil-extent stencil X))
 	 (y-ext (ly:stencil-extent stencil Y))
          (x-length (+ (interval-length x-ext) x-padding thickness))
@@ -188,8 +487,8 @@ encloses the contents.
 			    (interval-center y-ext))))))
 
 (define-public (ellipse-stencil stencil thickness x-padding y-padding)
-  "Add an ellipse around STENCIL, padded by the padding pair, 
-   producing a new stencil."
+  "Add an ellipse around @var{stencil}, padded by the padding pair,
+producing a new stencil."
   (let* ((x-ext (ly:stencil-extent stencil X))
 	 (y-ext (ly:stencil-extent stencil Y))
          (x-length (+ (interval-length x-ext) x-padding thickness))
@@ -210,7 +509,7 @@ encloses the contents.
 			    (interval-center y-ext))))))
 
 (define-public (rounded-box-stencil stencil thickness padding blot)
-   "Add a rounded box around STENCIL, producing a new stencil."  
+   "Add a rounded box around @var{stencil}, producing a new stencil."
 
   (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding))
 	 (yext (interval-widen (ly:stencil-extent stencil 1) padding))
@@ -218,74 +517,65 @@ encloses the contents.
    (ideal-blot (min blot (/ min-ext 2)))
    (ideal-thickness (min thickness (/ min-ext 2)))
 	 (outer (ly:round-filled-box
-            (interval-widen xext ideal-thickness) 
-            (interval-widen yext ideal-thickness) 
+            (interval-widen xext ideal-thickness)
+            (interval-widen yext ideal-thickness)
                ideal-blot))
-	 (inner (ly:make-stencil (list 'color (x11-color 'white) 
-            (ly:stencil-expr (ly:round-filled-box 
+	 (inner (ly:make-stencil (list 'color (x11-color 'white)
+            (ly:stencil-expr (ly:round-filled-box
                xext yext (- ideal-blot ideal-thickness)))))))
     (set! stencil (ly:stencil-add outer inner))
     stencil))
 
-
-(define-public (fontify-text font-metric text)
-  "Set TEXT with font FONT-METRIC, returning a stencil."
-  (let* ((b (ly:text-dimension font-metric text)))
-    (ly:make-stencil
-     `(text ,font-metric ,text) (car b) (cdr b))))
-     
-(define-public (fontify-text-white scale font-metric text)
-  "Set TEXT with scale factor SCALE"
-  (let* ((b (ly:text-dimension font-metric text))
-	 ;;urg -- workaround for using ps font
-         (c `(white-text ,(* 2 scale) ,text)))
-    ;;urg -- extent is not from ps font, but we hope it's close
-    (ly:make-stencil c (car b) (cdr b))))
-
 (define-public (stencil-with-color stencil color)
   (ly:make-stencil
    (list 'color color (ly:stencil-expr stencil))
    (ly:stencil-extent stencil X)
    (ly:stencil-extent stencil Y)))
-  
+
 (define-public (stencil-whiteout stencil)
   (let*
       ((x-ext (ly:stencil-extent stencil X))
        (y-ext (ly:stencil-extent stencil Y))
 
        )
-    
+
     (ly:stencil-add
      (stencil-with-color (ly:round-filled-box x-ext y-ext 0.0)
 			 white)
      stencil)
     ))
 
-(define-public (dimension-arrows destination) 
-  "Draw twosided arrow from here to @var{destination}"
-  
+(define-public (arrow-stencil-maker start? end?)
+  "Return a function drawing a line from current point to @code{destination},
+with optional arrows of @code{max-size} on start and end controlled by
+@var{start?} and @var{end?}."
+  (lambda (destination max-size)
   (let*
       ((e_x 1+0i)
        (e_y 0+1i)
+       (distance (sqrt (+ (* (car destination) (car destination))
+			  (* (cdr destination) (cdr destination)))))
+       (size (min max-size (/ distance 3)))
        (rotate (lambda (z ang)
 		 (* (make-polar 1 ang)
 		    z)))
        (complex-to-offset (lambda (z)
 			    (list (real-part z) (imag-part z))))
-       
+
        (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
        (e_z (/ z-dest (magnitude z-dest)))
-       (triangle-points '(-1+0.25i
-			  0
-			  -1-0.25i))
+       (triangle-points (list
+			 (* size -1+0.25i)
+			 0
+			 (* size -1-0.25i)))
        (p1s (map (lambda (z)
 		   (+ z-dest (rotate z (angle z-dest))))
 		 triangle-points))
        (p2s (map (lambda (z)
 		   (rotate z (angle (- z-dest))))
 		   triangle-points))
-       (null (cons 0 0)) 
-       (arrow-1  
+       (null (cons 0 0))
+       (arrow-1
 	(ly:make-stencil
 	 `(polygon (quote ,(concatenate (map complex-to-offset p1s)))
 		   0.0
@@ -295,11 +585,11 @@ encloses the contents.
 	 `(polygon (quote ,(concatenate (map complex-to-offset p2s)))
 		   0.0
 		   #t) null null ) )
-       (thickness 0.1)
-       (shorten-line 0.5)
+       (thickness (min (/ distance 12) 0.1))
+       (shorten-line (min (/ distance 3) 0.5))
        (start (complex-to-offset (/ (* e_z shorten-line) 2)))
        (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))
-       
+
        (line (ly:make-stencil
 	      `(draw-line ,thickness
 			  ,(car start) ,(cadr start)
@@ -309,17 +599,22 @@ encloses the contents.
 		    (min 0 (cdr destination)))
 	      (cons (max 0 (car destination))
 		    (max 0 (cdr destination)))))
-		    
-       (result (ly:stencil-add arrow-2 arrow-1 line)))
 
+       (result
+         (ly:stencil-add
+           (if start? arrow-2 empty-stencil)
+           (if end? arrow-1 empty-stencil)
+           line)))
+
+    result)))
 
-    result))
+(define-public dimension-arrows (arrow-stencil-maker #t #t))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; ANNOTATIONS
 ;;
 ;; annotations are arrows indicating the numerical value of
-;; spacing variables 
+;; spacing variables
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define*-public (annotate-y-interval layout name extent is-length
@@ -331,7 +626,7 @@ encloses the contents.
     (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. 
+    ;; do something sensible for 0,0 intervals.
     (set! extent (interval-widen extent 0.001))
     (if (not (interval-sane? extent))
 	(set! annotation (interpret-markup
@@ -351,8 +646,8 @@ encloses the contents.
                                               (else
                                                (ly:format "(~$,~$)"
                                                        (car extent) (cdr extent)))))))
-	      (arrows (ly:stencil-translate-axis 
-		       (dimension-arrows (cons 0 (interval-length extent)))
+	      (arrows (ly:stencil-translate-axis
+		       (dimension-arrows (cons 0 (interval-length extent)) 1.0)
 		       (interval-start extent) Y)))
 	  (set! annotation
                 (center-stencil-on-extent text-stencil))
@@ -369,6 +664,38 @@ encloses the contents.
     annotation))
 
 
+(define*-public (annotate-spacing-spec layout spacing-spec start-Y-offset prev-system-end
+				      #:key (base-color blue))
+  (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
+	 (space (get-spacing-var 'space))
+	 (padding (get-spacing-var 'padding))
+	 (min-dist (get-spacing-var 'minimum-distance))
+	 (contrast-color (append (cdr base-color) (list (car base-color)))))
+    (stack-stencils X RIGHT 0.0
+		    (list
+		     (annotate-y-interval layout
+					  "space"
+					  (cons (- start-Y-offset space) start-Y-offset)
+					  #t
+					  #:color (map (lambda (x) (* x 0.25)) base-color))
+		     (annotate-y-interval layout
+					  "min-dist"
+					  (cons (- start-Y-offset min-dist) start-Y-offset)
+					  #t
+					  #:color (map (lambda (x) (* x 0.5)) base-color))
+		     (ly:stencil-add
+		      (annotate-y-interval layout
+					   "bottom-of-extent"
+					   (cons prev-system-end start-Y-offset)
+					   #t
+					   #:color base-color)
+		      (annotate-y-interval layout
+					   "padding"
+					   (cons (- prev-system-end padding) prev-system-end)
+					   #t
+					   #:color contrast-color))))))
+
+
 (define-public (eps-file->stencil axis size file-name)
   (let*
       ((contents (ly:gulp-file file-name))
@@ -382,13 +709,16 @@ encloses the contents.
 		   0))
        (scaled-bbox
 	(map (lambda (x) (* factor x)) bbox))
+       ; We need to shift the whole eps to (0,0), otherwise it will appear
+       ; displaced in lilypond (displacement will depend on the scaling!)
+       (translate-string (ly:format "~a ~a translate" (- (list-ref bbox 0)) (- (list-ref bbox 1))))
        (clip-rect-string (ly:format
 			  "~a ~a ~a ~a rectclip"
-			  (list-ref bbox 0) 
-			  (list-ref bbox 1) 
+			  (list-ref bbox 0)
+			  (list-ref bbox 1)
 			  (- (list-ref bbox 2) (list-ref bbox 0))
 			  (- (list-ref bbox 3) (list-ref bbox 1)))))
-    
+
 
     (if bbox
 	(ly:make-stencil
@@ -401,9 +731,10 @@ gsave
 currentpoint translate
 BeginEPSF
 ~a dup scale
-~a 
+~a
+~a
 %%BeginDocument: ~a
-" 	   factor clip-rect-string
+"         factor translate-string  clip-rect-string
 
 	   file-name
 	   )
@@ -412,10 +743,11 @@ BeginEPSF
 EndEPSF
 grestore
 "))
-	
-	 (cons (list-ref scaled-bbox 0) (list-ref scaled-bbox 2))
-	 (cons (list-ref scaled-bbox 1) (list-ref scaled-bbox 3)))
-	
+	 ; Stencil starts at (0,0), since we have shifted the eps, and its
+         ; size is exactly the size of the scaled bounding box
+	 (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0)))
+	 (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1))))
+
 	(ly:make-stencil "" '(0 . 0) '(0 . 0)))
     ))
 
@@ -427,7 +759,7 @@ grestore
       (begin
 	(let*
 	    ((outname (simple-format #f "~a-~a.signature" basename count)) )
-	     
+
 	  (ly:message "Writing ~a" outname)
 	  (write-system-signature outname (car paper-systems))
 	  (write-system-signatures basename (cdr paper-systems) (1+ count))))))
@@ -439,7 +771,7 @@ grestore
 
   (define system-grob
     (paper-system-system-grob paper-system))
-  
+
   (define output (open-output-file filename))
 
   ;; todo: optionally use a command line flag? Or just junk this?
@@ -464,7 +796,7 @@ grestore
 	      (cons (fold-false-pairs first) rest)
 	      rest))
 	expr))
-  
+
   (define (raw-string expr)
     "escape quotes and slashes for python consumption"
     (regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post))
@@ -472,7 +804,7 @@ grestore
   (define (raw-pair expr)
     (simple-format #f "~a ~a"
 	    (car expr) (cdr expr)))
-  
+
   (define (found-grob expr)
     (let*
 	((grob (car expr))
@@ -518,7 +850,7 @@ grestore
 	  (for-each (lambda (e) (interpret e))  (cdr expr)))
 	 (else
 	  (collect (fold-false-pairs (strip-floats expr))))
-	 
+
 	 )))
 
     (interpret expr))
@@ -533,4 +865,4 @@ grestore
 
   ;; should be superfluous, but leaking "too many open files"?
   (close-port output))
-  
+