Merge branch 'master' of git://git.sv.gnu.org/lilypond.git into td-lily

[lilypond.git] / scm / stencil.scm

diff --git a/scm/stencil.scm b/scm/stencil.scm
index 32a64fdedee300616c5cccca1490fe29beef80f4..3256d49f61e6140b229cf0d721548d0966348648 100644 (file)
--- a/scm/stencil.scm
+++ b/scm/stencil.scm
@@ -2,7 +2,7 @@
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;; 
-;;;; (c) 2003--2006 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; (c) 2003--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
 
 (define-public (stack-stencils axis dir padding stils)
   "Stack stencils STILS in direction AXIS, DIR, using PADDING."
@@ -129,6 +129,25 @@ encloses the contents.
                            (interval-center x-ext)
                            (interval-center y-ext))))))
 
+(define-public (rounded-box-stencil stencil thickness padding blot)
+   "Add a rounded box around STENCIL, producing a new stencil."  
+
+  (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding))
+        (yext (interval-widen (ly:stencil-extent stencil 1) padding))
+   (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext))))
+   (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) 
+            ideal-blot))
+        (inner (ly:make-stencil (list 'color (x11-color 'white) (ly:stencil-expr (ly:round-filled-box 
+       (cons (+ (car xext) ideal-thickness) (- (cdr xext) ideal-thickness)) 
+       (cons (+ (car yext) ideal-thickness) (- (cdr yext) ideal-thickness)) 
+            (- ideal-blot (* ideal-thickness 2))))))))
+    (set! stencil (ly:stencil-add outer inner))
+    stencil))
+
 
 (define-public (fontify-text font-metric text)
   "Set TEXT with font FONT-METRIC, returning a stencil."
@@ -238,7 +257,7 @@ encloses the contents.
     (if (not (interval-sane? extent))
        (set! annotation (interpret-markup
                          layout text-props
-                         (make-simple-markup (format "~a: NaN/inf" name))))
+                         (make-simple-markup (simple-format #f "~a: NaN/inf" name))))
        (let ((text-stencil (interpret-markup
                             layout text-props
                              (markup #:whiteout #:simple name)))
@@ -249,9 +268,9 @@ encloses the contents.
                                               ((interval-empty? extent)
                                                (format "empty"))
                                               (is-length
-                                               (format "~$" (interval-length extent)))
+                                               (ly:format "~$" (interval-length extent)))
                                               (else
-                                               (format "(~$,~$)"
+                                               (ly:format "(~$,~$)"
                                                        (car extent) (cdr extent)))))))
              (arrows (ly:stencil-translate-axis 
                       (dimension-arrows (cons 0 (interval-length extent)))
@@ -279,10 +298,12 @@ encloses the contents.
                      (- (list-ref bbox 2) (list-ref bbox 0))
                      (- (list-ref bbox 3) (list-ref bbox 1))
                      ))
-       (factor (exact->inexact (/ size bbox-size)))
+       (factor (if (< 0 bbox-size)
+                  (exact->inexact (/ size bbox-size))
+                  0))
        (scaled-bbox
        (map (lambda (x) (* factor x)) bbox))
-       (clip-rect-string (format
+       (clip-rect-string (ly:format
                          "~a ~a ~a ~a rectclip"
                          (list-ref bbox 0) 
                          (list-ref bbox 1) 
@@ -295,7 +316,7 @@ encloses the contents.
         (list
          'embedded-ps
          (string-append
-          (format
+          (ly:format
           "
 gsave
 currentpoint translate
@@ -326,13 +347,12 @@ grestore
   (if (pair? paper-systems)
       (begin
        (let*
-           ((outname (format "~a-~a.signature" basename count)) )
+           ((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))))))
 
-
 (use-modules (scm paper-system))
 (define-public (write-system-signature filename paper-system)
   (define (float? x)
@@ -342,7 +362,9 @@ grestore
     (paper-system-system-grob paper-system))
   
   (define output (open-output-file filename))
-  
+
+  ;; todo: optionally use a command line flag? Or just junk this?
+  (define compare-expressions #f)
   (define (strip-floats expr)
     "Replace floats by #f"
     (cond
@@ -364,22 +386,12 @@ grestore
              rest))
        expr))
   
-
-  (define (pythonic-string expr)
-    "escape quotes and slashes for python consumption"
-    (regexp-substitute/global #f "([\n\\\\'\"])" (format "~a" expr) 'pre "\\" 1 'post))
-
-  (define (pythonic-pair expr)
-    (format "(~a,~a)"
-           (car expr) (cdr expr)))
-
-
   (define (raw-string expr)
     "escape quotes and slashes for python consumption"
-    (regexp-substitute/global #f "[@\n]" (format "~a" expr) 'pre " " 'post))
+    (regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post))
 
   (define (raw-pair expr)
-    (format "~a ~a"
+    (simple-format #f "~a ~a"
            (car expr) (cdr expr)))
   
   (define (found-grob expr)
@@ -394,13 +406,15 @@ grestore
         ;; todo: use stencil extent if available.
         (x-ext (ly:grob-extent grob system-grob X))
         (y-ext (ly:grob-extent grob system-grob Y))
-        )
-
-      (interpret-for-signature #f (lambda (e)
-                                   (set! collected (cons e collected)))
-                              rest)
-
-      (format output
+        (expression-skeleton
+         (if compare-expressions
+             (interpret-for-signature
+              #f (lambda (e)
+                   (set! collected (cons e collected)))
+              rest)
+            "")))
+
+      (simple-format output
              "~a@~a@~a@~a@~a\n"
              (cdr (assq 'name (ly:grob-property grob 'meta) ))
              (raw-string location)
@@ -432,7 +446,7 @@ grestore
 
   (if (ly:grob? system-grob)
       (begin
-       (display (format "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
+       (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
                 output)
        (interpret-for-signature found-grob (lambda (x) #f)
                                 (ly:stencil-expr