X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fps-to-png.scm;h=76773ab9ce8e071d6064b2342c9e691896536433;hb=e3b81fb69c751fd4610cca1457652d0c612516e6;hp=212029ed176f28df16843203c8c198d8c0775695;hpb=9d9aa44b75f4a97ea1399c12ab9bac299da08e6e;p=lilypond.git diff --git a/scm/ps-to-png.scm b/scm/ps-to-png.scm index 212029ed17..76773ab9ce 100644 --- a/scm/ps-to-png.scm +++ b/scm/ps-to-png.scm @@ -1,8 +1,19 @@ -;;;; ps-to-png.scm -- +;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; source file of the GNU LilyPond music typesetter -;;;; -;;;; (c) 2005--2006 Jan Nieuwenhuizen +;;;; Copyright (C) 2005--2010 Jan Nieuwenhuizen +;;;; +;;;; LilyPond is free software: you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation, either version 3 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; LilyPond is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with LilyPond. If not, see . (define-module (scm ps-to-png)) @@ -47,38 +58,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,65 +68,58 @@ (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))) + (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)) @@ -154,10 +128,10 @@ (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\ + (cmd (ly:format "~a\ ~a\ ~a\ -dGraphicsAlphaBits=4\ @@ -165,7 +139,7 @@ -dNOPAUSE\ -sDEVICE=~a\ -sOutputFile=~S\ - -r~S\ + -r~a\ ~S\ -c quit" (search-gs) @@ -208,7 +182,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)))