OLD | NEW |
| (Empty) |
1 ;;;; This file is part of LilyPond, the GNU music typesetter. | |
2 ;;;; | |
3 ;;;; Copyright (C) 2005--2019 Jan Nieuwenhuizen <janneke@gnu.org> | |
4 ;;;; | |
5 ;;;; LilyPond is free software: you can redistribute it and/or modify | |
6 ;;;; it under the terms of the GNU General Public License as published by | |
7 ;;;; the Free Software Foundation, either version 3 of the License, or | |
8 ;;;; (at your option) any later version. | |
9 ;;;; | |
10 ;;;; LilyPond is distributed in the hope that it will be useful, | |
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
13 ;;;; GNU General Public License for more details. | |
14 ;;;; | |
15 ;;;; You should have received a copy of the GNU General Public License | |
16 ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>. | |
17 | |
18 (define-module (scm ps-to-png)) | |
19 | |
20 (use-modules | |
21 (ice-9 optargs) | |
22 (ice-9 regex) | |
23 (ice-9 rw) | |
24 (srfi srfi-1) | |
25 (srfi srfi-13) | |
26 (srfi srfi-14) | |
27 (lily) | |
28 ) | |
29 | |
30 (define (re-sub re sub string) | |
31 (regexp-substitute/global #f re string 'pre sub 'post)) | |
32 | |
33 (define-public (gulp-file file-name . max-size) | |
34 (ly:gulp-file file-name (if (pair? max-size) (car max-size)))) | |
35 | |
36 (define (search-pngtopam) | |
37 (search-executable | |
38 (if (eq? PLATFORM 'windows) | |
39 '("pngtopam.exe" "pngtopnm.exe") | |
40 '("pngtopam" "pngtopnm")))) | |
41 | |
42 (define (search-pamscale) | |
43 (search-executable | |
44 (if (eq? PLATFORM 'windows) | |
45 '("pamscale.exe" "pnmscale.exe") | |
46 '("pamscale" "pnmscale")))) | |
47 | |
48 (define (search-pnmtopng) | |
49 (search-executable | |
50 (if (eq? PLATFORM 'windows) | |
51 '("pnmtopng.exe") | |
52 '("pnmtopng")))) | |
53 | |
54 (define (scale-down-image factor file) | |
55 (let* ((port-tmp1 (make-tmpfile)) | |
56 (tmp1-name (port-filename port-tmp1)) | |
57 (port-tmp2 (make-tmpfile)) | |
58 (tmp2-name (port-filename port-tmp2)) | |
59 ;; Netpbm commands (pngtopnm, pnmscale, pnmtopng) | |
60 ;; outputs only standard output instead of a file. | |
61 ;; So we need pipe and redirection. | |
62 ;; However, ly:system can't handle them. | |
63 ;; Therefore, we use ly:system-with-shell. | |
64 (cmd | |
65 (ly:format | |
66 "~a \"~a\" | ~a -reduce ~a | ~a -compression 9 > \"~a\"" | |
67 (search-pngtopam) tmp1-name | |
68 (search-pamscale) factor | |
69 (search-pnmtopng) | |
70 tmp2-name))) | |
71 | |
72 (close-port port-tmp1) | |
73 (close-port port-tmp2) | |
74 (ly:debug (_ "Copying `~a' to `~a'...") file tmp1-name) | |
75 (copy-binary-file file tmp1-name) | |
76 (ly:system-with-shell cmd) | |
77 (ly:debug (_ "Copying `~a' to `~a'...") tmp2-name file) | |
78 (copy-binary-file tmp2-name file) | |
79 (ly:debug (_ "Deleting `~a'...") tmp1-name) | |
80 (delete-file tmp1-name) | |
81 (ly:debug (_ "Deleting `~a'...") tmp2-name) | |
82 (delete-file tmp2-name))) | |
83 | |
84 (define-public (ps-page-count ps-name) | |
85 (let* ((byte-count 10240) | |
86 (header (gulp-file ps-name byte-count)) | |
87 (first-null (string-index header #\nul)) | |
88 (match (string-match "%%Pages: ([0-9]+)" | |
89 (if (number? first-null) | |
90 (substring header 0 first-null) | |
91 header)))) | |
92 (if match (string->number (match:substring match 1)) 0))) | |
93 | |
94 (define-public (make-ps-images base-name tmp-name is-eps . rest) | |
95 (let-keywords* | |
96 rest #f | |
97 ((resolution 90) | |
98 (page-width 100) | |
99 (page-height 100) | |
100 (rename-page-1 #f) | |
101 (be-verbose (ly:get-option 'verbose)) | |
102 (pixmap-format 'png16m) | |
103 (anti-alias-factor 1)) | |
104 | |
105 (let* ((format-str (format #f "~a" pixmap-format)) | |
106 (extension (cond | |
107 ((string-contains format-str "png") "png") | |
108 ((string-contains format-str "jpg") "jpeg") | |
109 ((string-contains format-str "jpeg") "jpeg") | |
110 (else | |
111 (ly:error "Unknown pixmap format ~a" pixmap-format)))) | |
112 (png1 (format #f "~a.~a" base-name extension)) | |
113 (pngn (format #f "~a-page%d.~a" base-name extension)) | |
114 (page-count (ps-page-count tmp-name)) | |
115 (multi-page? (> page-count 1)) | |
116 | |
117 ;; Escape `%' (except `page%d') for ghostscript | |
118 (base-name-gs (string-join | |
119 (string-split base-name #\%) | |
120 "%%")) | |
121 (png1-gs (format #f "~a.~a" base-name-gs extension)) | |
122 (pngn-gs (format #f "~a-page%d.~a" base-name-gs extension)) | |
123 (output-file (if multi-page? pngn-gs png1-gs)) | |
124 | |
125 (*unspecified* (if #f #f)) | |
126 (cmd | |
127 (remove (lambda (x) (eq? x *unspecified*)) | |
128 (list | |
129 (search-gs) | |
130 (if (ly:get-option 'verbose) *unspecified* "-q") | |
131 (if (or (ly:get-option 'gs-load-fonts) | |
132 (ly:get-option 'gs-load-lily-fonts) | |
133 (eq? PLATFORM 'windows)) | |
134 "-dNOSAFER" | |
135 "-dSAFER") | |
136 | |
137 (if is-eps | |
138 "-dEPSCrop" | |
139 (ly:format "-dDEVICEWIDTHPOINTS=~$" page-width)) | |
140 (if is-eps | |
141 *unspecified* | |
142 (ly:format "-dDEVICEHEIGHTPOINTS=~$" page-height)) | |
143 "-dGraphicsAlphaBits=4" | |
144 "-dTextAlphaBits=4" | |
145 "-dNOPAUSE" | |
146 "-dBATCH" | |
147 (ly:format "-sDEVICE=~a" pixmap-format) | |
148 "-dAutoRotatePages=/None" | |
149 "-dPrinted=false" | |
150 (string-append "-sOutputFile=" output-file) | |
151 (ly:format "-r~a" (* anti-alias-factor resolution)) | |
152 (string-append "-f" tmp-name)))) | |
153 (files '())) | |
154 | |
155 (ly:system cmd) | |
156 | |
157 (set! files | |
158 (if multi-page? | |
159 (map | |
160 (lambda (n) | |
161 (format #f "~a-page~a.png" base-name (1+ n))) | |
162 (iota page-count)) | |
163 (list (format #f "~a.png" base-name)))) | |
164 | |
165 (if (and rename-page-1 multi-page?) | |
166 (begin | |
167 (rename-file (re-sub "%d" "1" pngn) png1) | |
168 (set! files | |
169 (cons png1 | |
170 (cdr files))) | |
171 )) | |
172 | |
173 (if (not (= 1 anti-alias-factor)) | |
174 (for-each | |
175 (lambda (f) (scale-down-image anti-alias-factor f)) files)) | |
176 files))) | |
OLD | NEW |