Merge with master

[lilypond.git] / scm / output-ps.scm

diff --git a/scm/output-ps.scm b/scm/output-ps.scm
index 108771ee4b9bb2c51da3c2e06a6f523c20615c00..8af5b3fa3dd47d1164f2148fd51e90236a7ffcdd 100644 (file)
--- 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))
 
@@ -52,23 +52,26 @@
 ;;;
 
 
+;; ice-9 format uses a lot of memory
+;; using simple-format almost halves lilypond cell usage
+(define format simple-format)
+
 (define (escape-parentheses s)
   (regexp-substitute/global #f "(^|[^\\])([\\(\\)])" s 'pre 1 "\\" 2 'post))
 
-(define (ps-encoding text)
-  (escape-parentheses text))
-
-(define (round2 num)
-  (/ (round (* 100 num)) 100))
-
-(define (round4 num)
-  (/ (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")
+      (ly:number->string 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) " "))
@@ -106,11 +109,11 @@
 
 (define (circle radius thick fill)
   (format #f
-   "~a ~f ~f draw_circle"
+   "~a ~a ~a draw_circle"
    (if fill
      "true"
      "false")
-   (round4 radius) (round4 thick)))
+   (str4 radius) (str4 thick)))
 
 (define (dashed-line thick on off dx dy phase)
   (format #f "~a ~a ~a [ ~a ~a ] ~a draw_dashed_line"
@@ -154,9 +157,9 @@
 
   (define (glyph-spec w x y g)
     (let ((prefix (if (string? g) "/" "")))
-      (format #f "~f ~f ~a~a"
-             (round2 (+ w x))
-             (round2 y)
+      (format #f "~a ~a ~a~a"
+             (str4 (+ w x))
+             (str4 y)
              prefix g)))
   
   (format #f
@@ -191,18 +194,18 @@
 
          (if (and (< 0 (interval-length x-ext))
                   (< 0 (interval-length y-ext)))
-             (format #f "~$ ~$ ~$ ~$ (textedit://~a:~a:~a:~a) mark_URI\n"
-                     (+ (car offset) (car x-ext))
-                     (+ (cdr offset) (car y-ext))
-                     (+ (car offset) (cdr x-ext))
-                     (+ (cdr offset) (cdr y-ext))
+             (format #f "~a ~a ~a ~a (textedit://~a:~a:~a:~a) mark_URI\n"
+                     (str4 (+ (car offset) (car x-ext)))
+                     (str4 (+ (cdr offset) (car y-ext)))
+                     (str4 (+ (car offset) (cdr x-ext)))
+                     (str4 (+ (cdr offset) (cdr y-ext)))
 
                      ;; TODO
                      ;;full escaping.
 
                      ;; backslash is interpreted by GS.
-                     (string-regexp-substitute "\\\\" "/" 
-                                     (string-regexp-substitute " " "%20" file))
+                     (ly:string-substitute "\\" "/" 
+                                           (ly:string-substitute " " "%20" file))
                      (cadr location)
                      (caddr location)
                      (cadddr location))
@@ -248,9 +251,6 @@
     (format #f "~a draw_repeat_slash"
            (numbers->string4 (list x-width width height)))))
 
-;; restore color from stack
-(define (resetcolor) "setrgbcolor\n")
-
 
 (define (round-filled-box left right bottom top blotdiam)
   (let* ((halfblot (/ blotdiam 2))
@@ -264,12 +264,15 @@
 
 ;; 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 "gsave ~a translate ~a rotate ~a translate\n"
+  (format #f "gsave ~a translate ~a rotate ~a translate\n"
     (numbers->string4 (list x y))
     (number->string ang)
     (numbers->string4 (list (* -1 x) (* -1 y)))))
@@ -304,7 +307,7 @@
   "\n unknown\n")
 
 (define (url-link url x y)
-  (format #f "~$ ~$ ~$ ~$ (~a) mark_URI"
+  (format #f "~a ~a ~a ~a (~a) mark_URI"
          (car x)
          (car y)
          (cdr x)
@@ -340,14 +343,15 @@
             )
 
          ;; 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) " ")
+         (cons (format #f
+                       "~a ~a "
+                       (string-join (map (lambda (x) (format #f "~a " x)) args) " ")
                        head)
                (convert-path-exps (drop rest arity))))
        '()))
     
     
-  (format
+  (format #f
    "1 setlinecap ~a setlinewidth\n~a stroke"
    thickness
    (string-join (convert-path-exps exps) " ")))