X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fstencil.scm;h=047c0d0bb9622a2d514da8360bcca871e14f636b;hb=5b4b0d6e9a197e8f9eb085b7c2ad78b8be3e5cfc;hp=62b43cebc260a13f4f2ec3402c99ba9475dbe4df;hpb=9e69cb84d6ee5b0a861cd97869b10e3bdf0c833c;p=lilypond.git

diff --git a/scm/stencil.scm b/scm/stencil.scm
index 62b43cebc2..047c0d0bb9 100644
--- 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--2008 Han-Wen Nienhuys <hanwen@xs4all.nl>
 
 (define-public (stack-stencils axis dir padding stils)
   "Stack stencils STILS in direction AXIS, DIR, using PADDING."
@@ -30,14 +30,33 @@
 
 (define-public (stack-lines dir padding baseline stils)
   "Stack vertically with a baseline-skip."
-  (if (null? stils)
-      empty-stencil
-      (if (null? (cdr stils))
-	  (car stils)
-	  (ly:stencil-combine-at-edge
-	   (car stils) Y dir 
-	   (stack-lines dir padding baseline (cdr stils))
-	   padding baseline))))
+  (define result empty-stencil)
+  (define last-y #f)
+  (do
+      ((last-stencil #f (car p))
+       (p stils (cdr p)))
+      
+      ((null? p))
+
+    (if (number? last-y)
+	(begin
+	  (let* ((dy (max (+ (* dir (interval-bound (ly:stencil-extent last-stencil Y) dir))
+			     padding
+			     (* (- 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)))
+	(begin
+	  (set! last-y 0)
+	  (set! result (car p)))))
+
+  result)
+    
 
 (define-public (bracketify-stencil stil axis thick protusion padding)
   "Add brackets around STIL, producing a new stencil."
@@ -51,6 +70,17 @@
 	  (ly:stencil-combine-at-edge stil (other-axis axis) -1 rb padding))
     stil))
 
+(define-public (make-line-stencil width startx starty endx endy)
+  "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 
+      ; width to all coordinates!
+      (interval-widen xext (/ width 2))
+      (interval-widen yext (/ width 2)))))
+
 (define-public (make-filled-box-stencil xext yext)
   "Make a filled box."
   
@@ -61,10 +91,38 @@
 
 (define-public (make-circle-stencil radius thickness fill)
   "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) 
-   (cons (- radius) radius)
-   (cons (- radius) radius)))
+   (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}."
+  (let*
+      ((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) 
+   (cons (- x-out-radius) x-out-radius)
+   (cons (- y-out-radius) y-out-radius))))
+
+(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}."
+  (let*
+      ((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) 
+   (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
@@ -72,8 +130,8 @@ encloses the contents.
 "
   (let* ((xext (ly:grob-extent grob grob 0))
 	 (yext (ly:grob-extent grob grob 1))
-	 (thick 0.1))
-    
+	 (thick 0.01))
+
     (ly:stencil-add
      (make-filled-box-stencil xext (cons (- (car yext) thick) (car yext)))
      (make-filled-box-stencil xext (cons (cdr yext) (+ (cdr yext) thick)))
@@ -96,10 +154,10 @@ encloses the contents.
 
 (define-public (circle-stencil stencil thickness padding)
   "Add a circle around STENCIL, producing a new stencil."
-  (let* ((x-ext (ly:stencil-extent stencil 0))
-	 (y-ext (ly:stencil-extent stencil 1))
-	 (diameter (max (- (cdr x-ext) (car x-ext))
-			(- (cdr y-ext) (car y-ext))))
+  (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))) 
 	 (radius (+ (/ diameter 2) padding thickness))
 	 (circle (make-circle-stencil radius thickness #f)))
 
@@ -110,6 +168,64 @@ encloses the contents.
 			    (interval-center x-ext)
 			    (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."
+  (let* ((x-ext (ly:stencil-extent stencil X))
+	 (y-ext (ly:stencil-extent stencil Y))
+         (x-length (+ (interval-length x-ext) x-padding thickness))
+         (y-length (+ (interval-length y-ext) y-padding thickness))
+         (x-radius (* 0.707 x-length) )
+         (y-radius (* 0.707 y-length) )
+	 (oval (make-oval-stencil x-radius y-radius thickness #f)))
+
+    (ly:stencil-add
+     stencil
+     (ly:stencil-translate oval
+			   (cons
+			    (interval-center x-ext)
+			    (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."
+  (let* ((x-ext (ly:stencil-extent stencil X))
+	 (y-ext (ly:stencil-extent stencil Y))
+         (x-length (+ (interval-length x-ext) x-padding thickness))
+         (y-length (+ (interval-length y-ext) y-padding thickness))
+         ;(aspect-ratio (/ x-length y-length))
+         (x-radius (* 0.707 x-length) )
+         (y-radius (* 0.707 y-length) )
+	 ;(diameter (max (- (cdr x-ext) (car x-ext))
+	 ;		(- (cdr y-ext) (car y-ext))))
+	 ;(radius (+ (/ diameter 2) padding thickness))
+	 (ellipse (make-ellipse-stencil x-radius y-radius thickness #f)))
+
+    (ly:stencil-add
+     stencil
+     (ly:stencil-translate ellipse
+			   (cons
+			    (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 
+               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."
@@ -219,7 +335,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)))
@@ -230,9 +346,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)))
@@ -240,11 +356,11 @@ encloses the contents.
 	  (set! annotation
                 (center-stencil-on-extent text-stencil))
 	  (set! annotation
-		(ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5 0))
+		(ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5))
 	  (set! annotation
 		(ly:stencil-combine-at-edge annotation X LEFT
                                             (center-stencil-on-extent dim-stencil)
-                                            0.5 0))
+                                            0.5))
 	  (set! annotation
 		(ly:make-stencil (list 'color color (ly:stencil-expr annotation))
 				 (ly:stencil-extent annotation X)
@@ -255,28 +371,39 @@ encloses the contents.
 (define-public (eps-file->stencil axis size file-name)
   (let*
       ((contents (ly:gulp-file file-name))
-       (bbox (get-postscript-bbox contents))
+       (bbox (get-postscript-bbox (car (string-split contents #\nul))))
        (bbox-size (if (= axis X)
 		      (- (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)))
+	(map (lambda (x) (* factor x)) bbox))
+       (clip-rect-string (ly:format
+			  "~a ~a ~a ~a rectclip"
+			  (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
 	 (list
 	  'embedded-ps
 	  (string-append
-	   (format
+	   (ly:format
 	   "
 gsave
 currentpoint translate
 BeginEPSF
-~a ~a scale
+~a dup scale
+~a 
 %%BeginDocument: ~a
-" 	   factor factor
+" 	   factor clip-rect-string
+
 	   file-name
 	   )
 	   contents
@@ -298,13 +425,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)
@@ -314,7 +440,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
@@ -336,22 +464,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)
@@ -363,15 +481,18 @@ grestore
 	 (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f))
 	 (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '()))
 
+	 ;; 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)
@@ -403,7 +524,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