X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-ps.scm;h=42aecc1dbcb0364720adcb10a5bf687846a7bc3a;hb=2e613f5d4d7232507698d3a717576f46920a988b;hp=d7c55df028d4e1bae257ba6ba121f784d214b5ee;hpb=68d7330f72a14a8df49c49ed1566179248096092;p=lilypond.git

diff --git a/scm/output-ps.scm b/scm/output-ps.scm
index d7c55df028..42aecc1dbc 100644
--- a/scm/output-ps.scm
+++ b/scm/output-ps.scm
@@ -3,7 +3,7 @@
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;; 
 ;;;; (c) 1998--2006 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;;                 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+;;;;                 Han-Wen Nienhuys <hanwen@xs4all.nl>
 
 ;;;; Note: currently misused as testbed for titles with markup, see
 ;;;;       input/test/title-markup.ly
@@ -33,10 +33,10 @@
 	    polygon
 	    repeat-slash
 	    resetcolor
-	    resetrotatino
+	    resetrotation
 	    round-filled-box
 	    setcolor
-		setrotation
+	    setrotation
 	    text
 	    zigzag-line))
 
@@ -65,10 +65,18 @@
   (/ (round (* 10000 num)) 10000))
 
 (define (str4 num)
-  (format #f "~f" (round4 num)))
+  (if (or (nan? num) (inf? num))
+      (begin
+	(ly:warning (_ "Found infinity or nan in output. Substituting 0.0"))
+	(if (ly:get-option 'strict-infinity-checking)
+	    (exit 1))
+	"0.0")
+      (format #f "~f" (round4 num))))
 
 (define (number-pair->string4 numpair)
-  (format #f "~f ~f" (round4 (car numpair)) (round4 (cdr numpair))))
+  (string-append (str4 (car numpair))
+		 " "
+		 (str4 (cdr numpair))))
 
 (define (numbers->string4 numlist)
   (string-join (map str4 numlist) " "))
@@ -112,13 +120,16 @@
      "false")
    (round4 radius) (round4 thick)))
 
-(define (dashed-line thick on off dx dy)
-  (format #f "~a ~a ~a [ ~a ~a ] 0 draw_dashed_line"
+(define (dashed-line thick on off dx dy phase)
+  (format #f "~a ~a ~a [ ~a ~a ] ~a draw_dashed_line"
    (str4 dx)
    (str4 dy)
    (str4 thick)
    (str4 on)
-   (str4 off)))
+   (str4 off)
+   (str4 phase)
+   
+   ))
 
 ;; what the heck is this interface ?
 (define (dashed-slur thick on off l)
@@ -174,8 +185,8 @@
 
 (define (grob-cause offset grob)
   (let* ((cause (ly:grob-property grob 'cause))
-	 (music-origin (if (ly:music? cause)
-			   (ly:music-property cause 'origin))))
+	 (music-origin (if (ly:stream-event? cause)
+			   (ly:event-property cause 'origin))))
     (if (not (ly:input-location? music-origin))
 	""
 	(let* ((location (ly:input-file-line-char-column music-origin))
@@ -240,20 +251,11 @@
   (define (euclidean-length x y)
     (sqrt (+ (* x x) (* y y))))
 
-  (let ((x-width (euclidean-length slope (/ beam-thickness slope)))
+  (let ((x-width (euclidean-length beam-thickness (/ beam-thickness slope)))
 	(height (* width slope)))
     (format #f "~a draw_repeat_slash"
 	    (numbers->string4 (list x-width width height)))))
 
-;; restore color from stack
-(define (resetcolor) "setrgbcolor\n")
-
-;; reset rotation
-(define (resetrotation ang x y)
-  (format "~a translate ~a rotate ~a translate\n"
-    (numbers->string4 (list x y))
-    (number->string (* -1 ang))
-    (numbers->string4 (list (* -1 x) (* -1 y)))))
 
 (define (round-filled-box left right bottom top blotdiam)
   (let* ((halfblot (/ blotdiam 2))
@@ -267,16 +269,23 @@
 
 ;; save current color on stack and set new color
 (define (setcolor r g b)
-  (format #f "currentrgbcolor ~a setrgbcolor\n"
+  (format #f "gsave ~a setrgbcolor\n"
 	  (numbers->string4 (list r g b))))
 
+;; restore color from stack
+(define (resetcolor) "grestore \n")
+
 ;; rotation around given point
 (define (setrotation ang x y)
-  (format "~a translate ~a rotate ~a translate\n"
+  (format "gsave ~a translate ~a rotate ~a translate\n"
     (numbers->string4 (list x y))
     (number->string ang)
     (numbers->string4 (list (* -1 x) (* -1 y)))))
 
+(define (resetrotation ang x y)
+  "grestore  ")
+
+
 (define (text font s)
   ;; (ly:warning (_ "TEXT backend-command encountered in Pango backend"))
   ;; (ly:warning (_ "Arguments: ~a ~a"" font str))
@@ -322,3 +331,32 @@
    (str4 thick)
    (str4 dx)
    (str4 dy)))
+
+
+(define (path thickness exps)
+  (define (convert-path-exps exps)
+    (if (pair? exps)
+	(let*
+	    ((head (car exps))
+	     (rest (cdr exps))
+	     (arity 
+	      (cond
+	       ((memq head '(rmoveto rlineto lineto moveto)) 2)
+	       ((memq head '(rcurveto curveto)) 6)
+	       (else 1)))
+	     (args (take rest arity))
+	     )
+
+	  ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here.
+	  (cons (format "~a ~a "
+			(string-join (map (lambda (x) (format "~a " x)) args) " ")
+			head)
+		(convert-path-exps (drop rest arity))))
+	'()))
+    
+    
+  (format
+   "1 setlinecap ~a setlinewidth\n~a stroke"
+   thickness
+   (string-join (convert-path-exps exps) " ")))
+