]> git.donarmstrong.com Git - lilypond.git/blob - scm/output-ps.scm
Update makelsr script.
[lilypond.git] / scm / output-ps.scm
1 ;;;; output-ps.scm -- implement Scheme output interface for PostScript
2 ;;;;
3 ;;;;  source file of the GNU LilyPond music typesetter
4 ;;;; 
5 ;;;; (c) 1998--2006 Jan Nieuwenhuizen <janneke@gnu.org>
6 ;;;;                 Han-Wen Nienhuys <hanwen@xs4all.nl>
7
8 ;;;; Note: currently misused as testbed for titles with markup, see
9 ;;;;       input/test/title-markup.ly
10 ;;;; 
11 ;;;; TODO:
12 ;;;;   * %% Papersize in (header ...)
13 ;;;;   * text setting, kerning.
14 ;;;;   * document output-interface
15
16 (define-module (scm output-ps)
17   #:re-export (quote)
18
19   ;; JUNK this -- see lily.scm: ly:all-output-backend-commands
20   #:export (unknown
21             bezier-sandwich
22             char
23             circle
24             comment
25             dashed-line
26             dashed-slur
27             dot
28             draw-line
29             embedded-ps
30             named-glyph
31             no-origin
32             placebox
33             polygon
34             repeat-slash
35             resetcolor
36             resetrotation
37             round-filled-box
38             setcolor
39             setrotation
40             text
41             ))
42
43
44 (use-modules (guile)
45              (ice-9 regex)
46              (srfi srfi-1)
47              (srfi srfi-13)
48              (scm framework-ps)
49              (lily))
50
51 ;;; helper functions, not part of output interface
52 ;;;
53
54
55 ;; ice-9 format uses a lot of memory
56 ;; using simple-format almost halves lilypond cell usage
57
58 (define (str4 num)
59   (if (or (nan? num) (inf? num))
60       (begin
61         (ly:warning (_ "Found infinity or nan in output. Substituting 0.0"))
62         (if (ly:get-option 'strict-infinity-checking)
63             (exit 1))
64         "0.0")
65       (ly:number->string num)))
66
67 (define (number-pair->string4 numpair)
68   (ly:format "~4l" numpair)) 
69
70 (define (numbers->string4 numlist)
71   (string-join (map str4 numlist) " "))
72
73 ;;;
74 ;;; Lily output interface, PostScript implementation --- cleanup and docme
75 ;;;
76
77 ;; two beziers
78 (define (bezier-sandwich lst thick)
79   (ly:format "~l ~4f draw_bezier_sandwich" 
80              (map number-pair->string4 lst)
81           thick))
82
83 (define (char font i)
84   (ly:format "~a (\\~a) show"
85    (ps-font-command font)
86    (ly:inexact->string i 8)))
87
88 (define (circle radius thick fill)
89   (ly:format
90    "~a ~4f ~4f draw_circle"
91    (if fill
92      "true"
93      "false")
94    radius thick))
95
96 (define (dashed-line thick on off dx dy phase)
97   (ly:format "~4f ~4f ~4f [ ~4f ~4f ] ~4f draw_dashed_line"
98    dx
99    dy
100    thick
101    on
102    off
103    phase))
104
105 ;; what the heck is this interface ?
106 (define (dashed-slur thick on off l)
107   (ly:format "~l ~4f [ ~4f ~4f ] 0 draw_dashed_slur"
108           (let ((control-points (append (cddr l) (list (car l) (cadr l)))))
109             (map number-pair->string4 control-points))
110           thick
111           on
112           off))
113
114 (define (dot x y radius)
115   (ly:format " ~4l draw_dot" (list radius x y)))
116
117 (define (draw-line thick x1 y1 x2 y2)
118   (ly:format "~4f ~4f ~4f ~4f ~4f draw_line"
119           (- x2 x1) (- y2 y1)
120           x1 y1 thick))
121
122 (define (embedded-ps string)
123   string)
124
125 (define (glyph-string postscript-font-name
126                       size
127                       cid?
128                       w-x-y-named-glyphs)
129
130   (define (glyph-spec w x y g)
131     (let ((prefix (if (string? g) "/" "")))
132       (ly:format "~4f ~4f ~a~a"
133                  (+ w x)  y
134                  prefix g)))
135   
136   (ly:format 
137    (if cid?
138 "/~a /CIDFont findresource ~a output-scale div scalefont setfont
139 ~a
140 ~a print_glyphs"
141
142 "/~a ~a output-scale div selectfont
143 ~a
144 ~a print_glyphs")
145           postscript-font-name
146           size
147           (string-join (map (lambda (x) (apply glyph-spec x))
148                             (reverse w-x-y-named-glyphs)) "\n")
149           (length w-x-y-named-glyphs)))
150
151
152 (define (grob-cause offset grob)
153   (let* ((cause (ly:grob-property grob 'cause))
154          (music-origin (if (ly:stream-event? cause)
155                            (ly:event-property cause 'origin))))
156     (if (not (ly:input-location? music-origin))
157         ""
158         (let* ((location (ly:input-file-line-char-column music-origin))
159                (raw-file (car location))
160                (file (if (is-absolute? raw-file)
161                          raw-file
162                          (string-append (ly-getcwd) "/" raw-file)))
163                (x-ext (ly:grob-extent grob grob X))
164                (y-ext (ly:grob-extent grob grob Y)))
165
166           (if (and (< 0 (interval-length x-ext))
167                    (< 0 (interval-length y-ext)))
168               (ly:format "~4f ~4f ~4f ~4f (textedit://~a:~a:~a:~a) mark_URI\n"
169                          (+ (car offset) (car x-ext))
170                          (+ (cdr offset) (car y-ext))
171                          (+ (car offset) (cdr x-ext))
172                          (+ (cdr offset) (cdr y-ext))
173
174                          ;; TODO
175                          ;;full escaping.
176
177                          ;; backslash is interpreted by GS.
178                          (ly:string-substitute "\\" "/" 
179                                                (ly:string-substitute " " "%20" file))
180                          (cadr location)
181                          (caddr location)
182                          (cadddr location))
183               "")))))
184
185
186 (define (named-glyph font glyph)
187   (ly:format "~a /~a glyphshow " ;;Why is there a space at the end?
188              (ps-font-command font)
189              glyph))
190
191 (define (no-origin)
192   "")
193
194 (define (placebox x y s) 
195   (ly:format
196 "~4f ~4f moveto
197 ~a\n" x y s))
198
199 (define (polygon points blot-diameter filled?)
200   (ly:format "~a ~4l ~a ~4f draw_polygon"
201              (if filled? "true" "false")
202              points
203              (- (/ (length points) 2) 1)
204              blot-diameter))
205
206 (define (repeat-slash width slope beam-thickness)
207   (define (euclidean-length x y)
208     (sqrt (+ (* x x) (* y y))))
209
210   (let ((x-width (euclidean-length beam-thickness (/ beam-thickness slope)))
211         (height (* width slope)))
212     (ly:format "~4l draw_repeat_slash"
213              (list x-width width height))))
214
215
216 (define (round-filled-box left right bottom top blotdiam)
217   (let* ((halfblot (/ blotdiam 2))
218          (x (- halfblot left))
219          (width (- right (+ halfblot x)))
220          (y (- halfblot bottom))
221          (height (- top (+ halfblot y))))
222     (ly:format  "~4l draw_round_box"
223                 (list width height x y blotdiam))))
224
225 ;; save current color on stack and set new color
226 (define (setcolor r g b)
227   (ly:format "gsave ~4l setrgbcolor\n"
228               (list r g b)))
229
230 ;; restore color from stack
231 (define (resetcolor) "grestore \n")
232
233 ;; rotation around given point
234 (define (setrotation ang x y)
235   (ly:format "gsave ~4l translate ~a rotate ~4l translate\n"
236              (list x y)
237              ang
238              (list (* -1 x) (* -1 y))))
239
240 (define (resetrotation ang x y)
241   "grestore  ")
242
243
244 (define (text font s)
245   ;; (ly:warning (_ "TEXT backend-command encountered in Pango backend"))
246   ;; (ly:warning (_ "Arguments: ~a ~a"" font str))
247   
248   (let* ((space-length (cdar (ly:text-dimension font " ")))
249          (space-move (string-append (number->string space-length)
250                                     ;; how much precision do we need here?
251                                     " 0.0 rmoveto "))
252          (out-vec (decode-byte-string s)))
253
254     (string-append
255      (ps-font-command font) " "
256      (string-join
257       (vector->list
258        (vector-for-each
259         
260         (lambda (sym)
261           (if (eq? sym 'space)
262               space-move
263               (string-append "/" (symbol->string sym) " glyphshow")))
264         out-vec))))))
265
266 (define (unknown) 
267   "\n unknown\n")
268
269 (define (url-link url x y)
270   (ly:format "~a ~a ~a ~a (~a) mark_URI"
271              (car x)
272              (car y)
273              (cdr x)
274              (cdr y)
275              url))
276
277 (define (utf-8-string pango-font-description string)
278   (ly:warning (_ "utf-8-string encountered in PS backend")))
279
280 (define (path thickness exps)
281   (define (convert-path-exps exps)
282     (if (pair? exps)
283         (let*
284             ((head (car exps))
285              (rest (cdr exps))
286              (arity 
287               (cond
288                ((memq head '(rmoveto rlineto lineto moveto)) 2)
289                ((memq head '(rcurveto curveto)) 6)
290                (else 1)))
291              (args (take rest arity))
292              )
293
294           ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here.
295           (cons (ly:format
296                         "~l ~a "
297                         args 
298                         head)
299                 (convert-path-exps (drop rest arity))))
300         '()))
301     
302     
303   (ly:format
304    "1 setlinecap ~a setlinewidth\n~l stroke"
305    thickness
306    (convert-path-exps exps) ))
307