]> git.donarmstrong.com Git - lilypond.git/blob - scm/output-ps.scm
* scm/output-ps.scm (make-title, output-scopes): Further
[lilypond.git] / scm / output-ps.scm
1 ;;;; output-ps.scm -- implement Scheme output routines for PostScript
2 ;;;;
3 ;;;;  source file of the GNU LilyPond music typesetter
4 ;;;; 
5 ;;;; (c)  1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
6 ;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
7
8 ;; TODO:
9 ;;   * testbed for titles with markup
10 ;;   * font size and designsize
11 ;;   * FIXME: breaks when outputting strings with parentheses.
12
13
14 (debug-enable 'backtrace)
15
16 (define-module (scm output-ps))
17 (define this-module (current-module))
18
19 (use-modules
20  (guile)
21  (ice-9 regex)
22  (lily))
23
24
25 ;;; Lily output interface, PostScript implementation --- cleanup and docme
26
27 ;; Module entry
28 (define-public (ps-output-expression expr port)
29   (display (expression->string expr) port))
30
31
32 (define (expression->string expr)
33   (eval expr this-module))
34
35 ;; Global vars
36
37 ;; alist containing fontname -> fontcommand assoc (both strings)
38 (define font-name-alist '())
39
40 ;; WIP -- stencils from markup? values of output-scopes
41 (define header-stencil #f)
42
43 ;; Interface functions
44 (define (beam width slope thick blot)
45   (string-append
46    (numbers->string (list slope width thick blot)) " draw_beam" ))
47
48 ;; two beziers
49 (define (bezier-sandwich l thick)
50   (string-append 
51    (apply string-append (map number-pair->string l))
52    (ly:number->string thick)
53    " draw_bezier_sandwich "))
54
55 (define (bracket arch_angle arch_width arch_height  height arch_thick thick)
56   (string-append
57    (numbers->string
58     (list arch_angle arch_width arch_height height arch_thick thick))
59    " draw_bracket"))
60
61 (define (symmetric-x-triangle thick w h)
62   (string-append
63    (numbers->string (list h w thick))
64    " draw_symmetric_x_triangle"))
65
66
67 (define (char i)
68   (string-append 
69    "(\\" (inexact->string i 8) ") show " ))
70
71
72 (define (comment s)
73   (string-append "% " s "\n"))
74
75
76 (define (dashed-line thick on off dx dy)
77   (string-append 
78    (ly:number->string dx)
79    " "
80    (ly:number->string dy)
81    " "
82    (ly:number->string thick)
83    " [ "
84    (ly:number->string on)
85    " "
86    (ly:number->string off)
87    " ] 0 draw_dashed_line"))
88
89 ;; what the heck is this interface ?
90 (define (dashed-slur thick dash l)
91   (string-append 
92    (apply string-append (map number-pair->string l)) 
93    (ly:number->string thick) 
94    " [ "
95    (ly:number->string dash)
96    " "
97    ;;UGH.  10 ?
98    (ly:number->string (* 10 thick))
99    " ] 0 draw_dashed_slur"))
100
101 (define lily-traced-cm-fonts
102   (map symbol->string
103        '(cmbx14
104          cmbx17
105          cmbxti12
106          cmbxti14
107          cmbxti6
108          cmbxti7
109          cmbxti8
110          cmcsc12
111          cmcsc7
112          cmcsc8
113          cmss5
114          cmss6
115          cmss7
116          cmti5
117          cmti6
118          cmtt17
119          cmtt5
120          cmtt6
121          cmtt7)))
122
123
124 (define (define-fonts internal-external-name-mag-pairs)
125
126   (define (font-load-command name-mag command)
127
128     ;; frobnicate NAME to jibe with external definitions.
129     (define (possibly-capitalize-font-name name)
130       (cond
131        ((and (equal? (substring name 0 2) "cm")
132              (not (member name lily-traced-cm-fonts)))
133         
134         ;; huh, how is this supposed to work?
135         ;;(string-upcase name)
136         
137         (string-append name ".pfb"))
138        
139        ((equal? (substring name 0 4) "feta")
140         (regexp-substitute/global #f "feta([a-z-]*)([0-9]+)" name 'pre "GNU-LilyPond-feta" 1 "-" 2 'post))
141        (else name)))
142     
143     (string-append
144      "/" command
145      " { /"
146      ;; Ugh, the Bluesky type1 fonts for computer modern use capitalized 
147      ;; postscript font names.
148      (possibly-capitalize-font-name (car name-mag))
149      " findfont "
150      "20 " (ly:number->string (cdr name-mag)) " mul "
151      "output-scale div scalefont setfont } bind def "
152      "\n"))
153
154   (define (ps-encoded-fontswitch name-mag-pair)
155     (let* ((key (car name-mag-pair))
156            (value (cdr name-mag-pair)))
157       (cons key
158             (cons value
159                   (string-append "lilyfont"
160                                  (car value)
161                                  "-"
162                                  (number->string (cdr value)))))))
163       
164   (set! font-name-alist (map ps-encoded-fontswitch
165                              internal-external-name-mag-pairs))
166
167   (apply string-append
168          (map (lambda (x) (font-load-command (car x) (cdr x)))
169               (map cdr font-name-alist))))
170
171 (define (define-origin file line col) "")
172
173 (define (dot x y radius)
174   (string-append
175    " "
176    (numbers->string
177     (list x y radius)) " draw_dot"))
178
179 (define (zigzag-line centre? zzw zzh thick dx dy)
180   (string-append
181     (if centre? "true" "false")
182     " "
183     (ly:number->string zzw)
184     " "
185     (ly:number->string zzh)
186     " "
187     (ly:number->string thick)
188     " 0 0 "
189     (ly:number->string dx)
190     " "
191     (ly:number->string dy)
192     " draw_zigzag_line "))
193
194 (define (draw-line thick x1 y1 x2 y2)
195   (string-append 
196   "     1 setlinecap
197         1 setlinejoin "
198   (ly:number->string thick)
199         " setlinewidth "
200    (ly:number->string x1)
201    " "
202    (ly:number->string y1)
203    " moveto "
204    (ly:number->string x2)
205    " "
206    (ly:number->string y2)
207    " lineto stroke"))
208
209 (define (polygon points blotdiameter)
210   (string-append
211    " "
212    (numbers->string points)
213    (ly:number->string (/ (length points) 2))
214    (ly:number->string blotdiameter)
215    " draw_polygon"))
216
217 (define (end-output)
218   "\nend-lilypond-output\n")
219
220 (define (ez-ball ch letter-col ball-col)
221   (string-append
222    " (" ch ") "
223    (numbers->string (list letter-col ball-col))
224    " /Helvetica-Bold " ;; ugh
225    " draw_ez_ball"))
226
227 (define (filledbox breapth width depth height) 
228   (string-append (numbers->string (list breapth width depth height))
229                  " draw_box"))
230
231 (define (horizontal-line x1 x2 th)
232   (draw-line th x1  0 x2 0))
233
234 (define (fontify name-mag-pair exp)
235
236   (define (select-font name-mag-pair)
237     (let ((c (assoc name-mag-pair font-name-alist)))
238       
239       (if c
240           (string-append " " (cddr c) " ")
241           (begin
242             (ly:warn
243              (format "Programming error: No such font: ~S" name-mag-pair))
244             
245             (display "FAILED\n" (current-error-port))
246             (if #f ;(pair? name-mag-pair))
247                 (display (object-type (car name-mag-pair)) (current-error-port))
248                 (write name-mag-pair (current-error-port)))
249             (if #f ;  (pair? font-name-alist)
250                 (display
251                  (object-type (caaar font-name-alist)) (current-error-port))
252                 (write font-name-alist (current-error-port)))
253
254             ;; (format #f "\n%FAILED: (select-font ~S)\n" name-mag-pair))
255             ""))))
256   
257   (string-append (select-font name-mag-pair) exp))
258
259 (define (header creator generate) 
260   (string-append
261    "%!PS-Adobe-3.0\n"
262    "%%Creator: " creator generate "\n"))
263
264 (define (header-end)
265   (string-append
266    ;; URG: now we can't use scm output without Lily
267    (ly:gulp-file "lilyponddefs.ps")
268    "{exch pop //systemdict /run get exec}\n\n"
269    (ly:gulp-file "music-drawing-routines.ps")
270    "{ exch pop //systemdict /run get exec }\n\n"
271    ;; ps-testing wreaks havoc when used with lilypond-book.
272    ;;  -- is this still true with new modules system?
273 ;;   (if (defined? 'ps-testing) "\n /testing true def" "")
274   ;   "\n /testing true def"
275    ))
276
277 (define (lily-def key val)
278   (let ((prefix "lilypondpaper"))
279     (if (string=?
280          (substring key 0 (min (string-length prefix) (string-length key)))
281          prefix)
282         (string-append "/" key " {" val "} bind def\n")
283         (string-append "/" key " (" val ") def\n"))))
284
285 (define (no-origin) "")
286   
287 (define (placebox x y s) 
288   (string-append 
289    (ly:number->string x) " " (ly:number->string y) " {" s "} place-box\n"))
290
291 (define (repeat-slash wid slope thick)
292   (string-append
293    (numbers->string (list wid slope thick))
294    " draw_repeat_slash"))
295
296 (define (round-filled-box x y width height blotdiam)
297    (string-append
298     " "
299     (numbers->string
300      (list x y width height blotdiam)) " draw_round_box"))
301
302 (define (start-system width height)
303   (string-append
304    "\n" (ly:number->string height)
305    " start-system\n"
306    "{\n"
307    "set-ps-scale-to-lily-scale\n"))
308
309 (define (stem breapth width depth height) 
310   (string-append
311    (numbers->string (list breapth width depth height))
312    " draw_box" ))
313
314 (define (stop-last-system)
315   (stop-system))
316
317 (define (stop-system)
318   "}\nstop-system\n")
319
320 (define (text s)
321   (string-append "(" s ") show "))
322
323 (define (unknown) 
324   "\n unknown\n")
325
326 ;; top-of-file, wtf?
327 (define (top-of-file)
328   (header (string-append "GNU LilyPond (" (lilypond-version) "), ")
329           (strftime "%c" (localtime (current-time))))
330   ;;; ugh
331   (ps-string-def
332    "lilypond" 'tagline
333    (string-append "Engraved by LilyPond (" (lilypond-version) ")")))
334
335 (define (output-paper-def pd)
336   (apply
337    string-append
338    (module-map
339     (lambda (sym var)
340       (let ((val (variable-ref var))
341             (key (symbol->string sym)))
342         
343         (cond
344          ((string? val)
345           (ps-string-def "lilypondpaper" sym val))
346          ((number? val)
347           (ps-number-def "lilypondpaper" sym
348                          (if (integer? val)
349                              (number->string val)
350                              (number->string (exact->inexact val)))))
351          (else ""))))
352       
353     (ly:output-def-scope pd))))
354
355
356 (define (ps-string-def a b c)
357   (string-append "/" a (symbol->string b) " (" c ") def\n"))
358
359 (define (ps-number-def a b c)
360   (string-append "/" a (symbol->string b) " " c " def\n"))
361
362
363 (define (output-scopes paper scopes fields basename)
364
365   ;; FIXME: customise/generate these
366   (let ((props '(((font-family . roman)
367                   (word-space . 1)
368                   (baseline-skip . 2)
369                   (font-series . medium)
370                   (font-style . roman)
371                   (font-shape . upright)
372                   (font-size . 0))))
373         (stencils '())
374         (baseline-skip 2))
375
376     (define (output-scope-entry sym var)
377       (let ((val (variable-ref var))
378             (tex-key (symbol->string sym)))
379         
380         (if (memq sym fields)
381             (header-to-file basename sym val))
382         
383         (cond
384          ((eq? sym 'font)
385           BARF
386           (format (current-error-port) "PROPS:~S\n" val)
387           (set! props (cons val props))
388           "")
389          
390          ;; define strings, for /make-lilypond-title to pick up
391          ((string? val) (ps-string-def "lilypond" sym val))
392          
393          ;; generate stencil from markup
394          ((markup? val) (set! stencils
395                               (append
396                                stencils
397                                (list
398                                 (interpret-markup paper props val))))
399           "")
400          ((number? val) (ps-number-def
401                          "lilypond" sym (if (integer? val)
402                                             (number->string val)
403                                             (number->string
404                                              (exact->inexact val)))))
405          (else ""))))
406     
407     (define (output-scope scope)
408       (apply string-append (module-map output-scope-entry scope)))
409
410     (let ((s (string-append (apply string-append (map output-scope scopes)))))
411       (set! header-stencil (stack-lines DOWN 0 baseline-skip stencils))
412       
413       ;; trigger font load
414       (ly:stencil-get-expr header-stencil)
415       s)))
416
417 (define (offset-add a b)
418   (cons (+ (car a) (car b))
419         (+ (cdr a) (cdr b))))
420
421 (define (make-title port)
422   (if header-stencil
423       (let ((x-ext (ly:stencil-get-extent header-stencil Y))
424             (y-ext (ly:stencil-get-extent header-stencil X)))
425         (display (start-system (interval-length x-ext) (interval-length y-ext))
426                  port)
427         (output-stencil port (ly:stencil-get-expr header-stencil) '(0 . 0))
428         (display (stop-system) port)))
429   "")
430
431 ;; hmm, looks like recursing call is always last statement, does guile
432 ;; think so too?
433 (define (output-stencil port expr offset)
434   (if (pair? expr)
435       (let ((head (car expr)))
436         (cond
437          ((ly:input-location? head)
438           (display (apply define-origin (ly:input-location head)) port)
439           (output-stencil port (cadr expr) offset))
440          ((eq? head 'no-origin)
441           (display (expression->string head) port)
442           (output-stencil port (cadr expr) offset))
443          ((eq? head 'translate-stencil)
444           (output-stencil port (caddr expr) (offset-add offset (cadr expr))))
445          ((eq? head 'combine-stencil)
446           (output-stencil port (cadr expr) offset)
447           (output-stencil port (caddr expr) offset))
448          (else
449           (display (placebox (car offset) (cdr offset)
450                              (expression->string expr)) port))))))
451