Run `make grand-replace'.

[lilypond.git] / scm / ps-to-png.scm

diff --git a/scm/ps-to-png.scm b/scm/ps-to-png.scm
index 2e124ae5acd4915d9beb404981f13d14955297cf..c70dbf8628572ad6f6125b2d583a39034351b836 100644 (file)
--- a/scm/ps-to-png.scm
+++ b/scm/ps-to-png.scm
@@ -2,7 +2,7 @@
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;; 
-;;;; (c) 2005--2006 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; (c) 2005--2008 Jan Nieuwenhuizen <janneke@gnu.org>
 
 (define-module (scm ps-to-png))
 
@@ -47,38 +47,8 @@
     (read-string!/partial str port 0 max-length)
     str))
 
-(define (gulp-file nm len)
-
-  ;; string routines barf when strlen() != string-length,.
-  ;; which may happen as side effect of read-string!/partial.
-  
-                                       ;  (gulp-port (open-file nm "r") len))
-  (ly:gulp-file nm len))
-
-
-(define BOUNDING-BOX-RE
-  "^%%BoundingBox: (-?[0-9]+) (-?[0-9]+) (-?[0-9]+) (-?[0-9]+)")
-
-(define (get-bbox file-name)
-  (let* ((bbox (string-append file-name ".bbox"))
-        ;; -sOutputFile does not work with bbox?
-        (cmd (format #t "gs\
- -sDEVICE=bbox\
- -q\
- -dNOPAUSE\
- ~S\
- -c showpage\
- -c quit 2>~S"
-                     file-name bbox))
-        (status (system cmd))
-        (s (gulp-file d bbox 10240))
-        (m (string-match BOUNDING_BOX_RE s)))
-
-    (if m
-       (list->vector
-        (map (lambda (x) (string->number (car x))) (vector->list m)))
-       #f)))
-
+(define-public (gulp-file file-name . max-size)
+  (ly:gulp-file file-name (if (pair? max-size) (car max-size))))
 
 ;; copy of ly:system. ly:* not available via lilypond-ps2png.scm
 (define (my-system be-verbose exit-on-error cmd)
@@ -87,76 +57,69 @@
       (begin
        (format (current-error-port) (_ "Invoking `~a'...") cmd)
        (newline (current-error-port))))
-
-  
   (set! status (system cmd))
-  
   (if (not (= status 0))
       (begin
        (format (current-error-port)
                (format #f (_ "~a exited with status: ~S") "GS" status))
-       (if exit-on-error
-           (exit 1))))
-
+       (if exit-on-error (exit 1))))
   status)
 
 (define (scale-down-image be-verbose factor file)
-  (let* ((status 0)
-        (percentage (* 100 (/ 1.0 factor)))
-        (old (string-append file ".old")))
-
-    (rename-file file old)
-    (my-system be-verbose
-              #t
-              (format #f "convert -scale \"~a%\" ~a ~a" percentage old file))
-    (delete-file old)
-    ))
+  (define (with-pbm)
+    (let* ((status 0)
+          (old (string-append file ".old")))
+      
+      (rename-file file old)
+      (my-system
+       be-verbose #t
+       (format #f
+              "pngtopnm ~a | pnmscale -reduce ~a 2>/dev/null | pnmtopng -compression 9 2>/dev/null > ~a"
+              old factor file))
+      (delete-file old)))
+
+  (with-pbm))
 
 (define-public (ps-page-count ps-name)
-  (let*
-      ((byte-count 10240)
-       (header (gulp-file ps-name byte-count))
-       (first-null (string-index header #\nul))
-       (match (string-match "%%Pages: ([0-9]+)"
-                           (if (number? first-null)
-                               (substring header 0 first-null)
-                               header))))
-
-    (if match
-       (string->number (match:substring match 1))
-       0)))
+  (let* ((byte-count 10240)
+        (header (gulp-file ps-name byte-count))
+        (first-null (string-index header #\nul))
+        (match (string-match "%%Pages: ([0-9]+)"
+                             (if (number? first-null)
+                                 (substring header 0 first-null)
+                                 header))))
+    (if match (string->number (match:substring match 1)) 0)))
 
 (define-public (make-ps-images ps-name . rest)
   (let-keywords*
    rest #f
-     ((resolution 90)
-      (page-width  100)
-      (page-height 100)
-      (rename-page-1 #f)
-      (be-verbose #f)
-      (pixmap-format 'png16m)
-      (anti-alias-factor 1))
-     
-   (let* (
-         (format-str (format "~a" pixmap-format))
+   ((resolution 90)
+    (page-width  100)
+    (page-height 100)
+    (rename-page-1 #f)
+    (be-verbose (ly:get-option 'verbose))
+    (pixmap-format 'png16m)
+    (anti-alias-factor 1))
+
+   (let* ((format-str (format "~a" pixmap-format))
          (extension (cond
                      ((string-contains format-str "png") "png")
                      ((string-contains format-str "jpg") "jpeg")
                      ((string-contains format-str "jpeg") "jpeg")
                      (else
                       (ly:error "Unknown pixmap format ~a" pixmap-format))))
-         (base (basename (re-sub "[.]e?ps" "" ps-name)))
-         (png1 (format "~a.~a" base pixmap-format))
-         (pngn (format  "~a-page%d.~a" base pixmap-format))
+         (base (dir-basename ps-name ".ps" ".eps"))
+         (png1 (format "~a.~a" base extension))
+         (pngn (format  "~a-page%d.~a" base extension))
          (page-count (ps-page-count ps-name))
          (multi-page? (> page-count 1))
          (output-file (if multi-page? pngn png1))
 
          (gs-variable-options
           (if multi-page?
-              (format #f "-dDEVICEWIDTHPOINTS=~,2f -dDEVICEHEIGHTPOINTS=~,2f" page-width page-height)
+              (format #f "-dDEVICEWIDTHPOINTS=~,2f -dDEVICEHEIGHTPOINTS=~,2f"
+                      page-width page-height)
               "-dEPSCrop"))
-
          (cmd (format #f "~a\
  ~a\
  ~a\
@@ -208,7 +171,6 @@
           ))
 
      (if (not (= 1 anti-alias-factor))
-        (for-each  (lambda (f) (scale-down-image be-verbose anti-alias-factor f))
-                   files))
-
+        (for-each
+         (lambda (f) (scale-down-image be-verbose anti-alias-factor f)) files))
      files)))