1 ; lily.scm -- implement Scheme output routines for TeX and PostScript
3 ; source file of the GNU LilyPond music typesetter
5 ; (c) 1998 Jan Nieuwenhuizen <janneke@gnu.org>
9 ; - ready ps code (draw_bracket) vs tex/ps macros/calls (pianobrace),
10 ; all preparations from ps,tex to scm
16 (map (lambda (n) (string-append (number->string n ) " ")) l)))
21 (map (lambda (n) (string-append (number->string n) " ")) l)))
23 (define (chop-decimal x) (if (< (abs x) 0.001) 0.0 x))
25 (define (number->octal-string x)
26 (let* ((n (inexact->exact x))
28 (n8 (quotient (- n (* n64 64)) 8)))
32 (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
34 (define (inexact->string x radix)
35 (let ((n (inexact->exact x)))
36 (number->string n radix)))
42 (string-append (number->string (car c)) " ")
43 (string-append (number->string (cadr c)) " ")))
50 (make-string 1 (integer->char (+ (char->integer #\A) i)))
55 (define (scm-scm action-name)
58 (define security-paranoia #f)
73 (define emptybar empty1)
75 ;;; and these suck as well.
76 (define (setdynamic s) (text "dynamic" (string-append "\\" s)))
77 (define (settext s) (text "text" s))
78 (define (settypewriter s) (text "typewriter" s))
79 (define (setnumber s) (text "number" s))
80 (define (setbold s) (text "bold" s))
81 (define (setfinger s) (text "finger" s))
82 (define (setitalic s) (text "italic" s))
83 (define (setnumber-1 s) (text "numberj" s))
89 (define (tex-scm action-name)
94 (define (beam width slope thick)
95 (embedded-ps ((ps-scm 'beam) width slope thick)))
98 (embedded-ps ((ps-scm 'bracket) h)))
100 (define (dashed-slur thick dash l)
101 (embedded-ps ((ps-scm 'dashed-slur) thick dash l)))
103 (define (crescendo w h cont)
104 (embedded-ps ((ps-scm 'crescendo) w h cont)))
106 (define (decrescendo w h cont)
107 (embedded-ps ((ps-scm 'decrescendo) w h cont)))
111 (invoke-dim1 "doublebar" h))
113 (define (embedded-ps s)
114 (string-append "\\embeddedps{" s "}"))
117 "\n\\EndLilyPondOutput")
119 (define (experimental-on) "\\turnOnExperimentalFeatures")
122 (invoke-dim1 "extender" h))
126 (invoke-dim1 "fatdoublebar" h))
130 (invoke-dim1 "finishbar" h))
132 (define (font-switch i)
136 (define (font-def i s)
138 "\\font" (font-switch i) "=" s "\n"))
140 (define (generalmeter num den)
142 "\\generalmeter{" (number->string (inexact->exact num)) "}{" (number->string (inexact->exact den)) "}"))
144 (define (header-end) "\\turnOnPostScript")
146 (define (header creator generate)
148 "%created by: " creator generate "\n"))
150 (define (invoke-char s i)
152 "\n\\" s "{" (inexact->string i 10) "}" ))
154 (string-append "\\show{" (inexact->string i 10) "}"))
156 (define (invoke-dim1 s d)
158 "\n\\" s "{" (number->dim d) "}"))
161 ;; need to do something to make this really safe.
163 (if security-paranoia
164 (define (output-tex-string s)
165 (regexp-substitute/global #f "\\\\" s 'pre "$\\backslash$" 'post))
166 (define (output-tex-string s) s))
168 (define (lily-def key val)
170 "\\def\\" (output-tex-string key) "{" (output-tex-string val) "}\n"))
172 (define (number->dim x)
174 (number->string (chop-decimal x)) "pt "))
176 (define (placebox x y s)
179 (number->dim y) "}{" (number->dim x) "}{" s "}"))
181 (define (pianobrace y)
183 (define minht mudelapaperstaffheight)
184 (define maxht (* 6 minht))
186 "{\\bracefont " (char (/ (- (min y (- maxht step)) minht) step)) "}"))
190 (invoke-dim1 "repeatbar" h))
193 (repeatbarstartrepeat h)
194 (invoke-dim1 "repeatbarstartrepeat" h))
196 (define (rulesym h w)
198 "\\vrule height " (number->dim (/ h 2))
199 " depth " (number->dim (/ h 2))
200 " width " (number->dim w)
205 (embedded-ps ((ps-scm 'slur) l)))
209 (invoke-dim1 "startbar" h))
213 (invoke-dim1 "startrepeat" h))
220 (define (stem kern width height depth)
222 "\\kern" (number->dim kern)
223 "\\vrule width " (number->dim width)
224 "depth " (number->dim depth)
225 "height " (number->dim height) " "))
232 (invoke-dim1 "stoprepeat" h))
235 (string-append "\\set" f "{" (output-tex-string s) "}"))
237 (define (tuplet dx dy dir)
238 (embedded-ps ((ps-scm 'tuplet) dx dy dir)))
240 (define (volta w last)
241 (embedded-ps ((ps-scm 'volta) w last)))
243 (define (maatstreep h)
244 (string-append "\\maatstreep{" (number->dim h) "}"))
247 (cond ((eq? action-name 'all-definitions)
250 (define tuplet ,tuplet)
251 (define bracket ,bracket)
252 (define crescendo ,crescendo)
253 (define dashed-slur ,dashed-slur)
254 (define doublebar ,doublebar)
255 (define emptybar ,emptybar)
256 (define decrescendo ,decrescendo)
257 (define empty ,empty)
258 (define end-output ,end-output)
259 (define extender ,extender)
260 (define fatdoublebar ,fatdoublebar)
261 (define finishbar ,finishbar)
262 (define font-def ,font-def)
263 (define font-switch ,font-switch)
264 (define generalmeter ,generalmeter)
265 (define header-end ,header-end)
266 (define lily-def ,lily-def)
267 (define header ,header)
268 (define invoke-char ,invoke-char)
269 (define invoke-dim1 ,invoke-dim1)
270 (define placebox ,placebox)
271 (define repeatbar ,repeatbar)
272 (define repeatbarstartrepeat ,repeatbarstartrepeat)
273 (define rulesym ,rulesym)
275 (define startbar ,startbar)
276 (define startrepeat ,startrepeat)
277 (define stoprepeat ,stoprepeat)
278 (define start-line ,start-line)
280 (define stop-line ,stop-line)
282 (define experimental-on ,experimental-on)
284 (define maatstreep ,maatstreep)
285 (define pianobrace ,pianobrace)
286 (define volta ,volta)
289 ((eq? action-name 'experimental-on) experimental-on)
290 ((eq? action-name 'beam) beam)
291 ((eq? action-name 'tuplet) tuplet)
292 ((eq? action-name 'bracket) bracket)
293 ((eq? action-name 'crescendo) crescendo)
294 ((eq? action-name 'dashed-slur) dashed-slur)
295 ((eq? action-name 'doublebar) doublebar)
296 ((eq? action-name 'decrescendo) decrescendo)
297 ((eq? action-name 'empty) empty)
298 ((eq? action-name 'end-output) end-output)
299 ((eq? action-name 'extender) extender)
300 ((eq? action-name 'fatdoublebar) fatdoublebar)
301 ((eq? action-name 'finishbar) finishbar)
302 ((eq? action-name 'font-def) font-def)
303 ((eq? action-name 'font-switch) font-switch)
304 ((eq? action-name 'generalmeter) generalmeter)
305 ((eq? action-name 'header-end) header-end)
306 ((eq? action-name 'lily-def) lily-def)
307 ((eq? action-name 'header) header)
308 ((eq? action-name 'invoke-char) invoke-char)
309 ((eq? action-name 'invoke-dim1) invoke-dim1)
310 ((eq? action-name 'placebox) placebox)
311 ((eq? action-name 'repeatbar) repeatbar)
312 ((eq? action-name 'repeatbarstartrepeat) repeatbarstartrepeat)
313 ((eq? action-name 'rulesym) rulesym)
314 ((eq? action-name 'slur) slur)
315 ((eq? action-name 'startbar) startbar)
316 ((eq? action-name 'startrepeat) startrepeat)
317 ((eq? action-name 'stoprepeat) stoprepeat)
318 ((eq? action-name 'start-line) start-line)
319 ((eq? action-name 'stem) stem)
320 ((eq? action-name 'stop-line) stop-line)
321 ((eq? action-name 'volta) volta)
322 (else (error "unknown tag -- PS-TEX " action-name))
327 (define (ps-scm action-name)
328 (define (beam width slope thick)
330 (numbers->string (list width slope thick)) " draw_beam " ))
333 (invoke-dim1 "draw_bracket" h))
335 (define (crescendo w h cont)
337 (numbers->string (list w h (inexact->exact cont)))
340 (define (dashed-slur thick dash l)
342 (apply string-append (map control->string l))
343 (number->string thick)
345 (if (> 1 dash) (number->string (- (* thick dash) thick)) "0") " "
346 (number->string (* 2 thick))
347 " ] 0 draw_dashed_slur"))
349 (define (decrescendo w h cont)
351 (numbers->string (list w h (inexact->exact cont)))
360 (define (experimental-on) "")
362 (define (font-def i s)
365 (substring s 0 (- (string-length s) 4))
366 " findfont 12 scalefont setfont} bind def\n"))
368 (define (font-switch i)
369 (string-append (font i) " "))
371 (define (generalmeter num den)
372 (string-append (number->string (inexact->exact num)) " " (number->string (inexact->exact den)) " generalmeter "))
374 (define (header-end) "")
375 (define (lily-def key val)
377 "/" key " {" val "} bind def\n"))
379 (define (header creator generate)
382 "%%Creator: " creator generate "\n"))
384 (define (invoke-char s i)
386 "(\\" (inexact->string i 8) ") " s " " ))
388 (define (invoke-dim1 s d)
390 (number->string d) " " s ))
392 (define (placebox x y s)
394 (number->string x) " " (number->string y) " {" s "} placebox "))
396 (define (rulesym x y)
398 (number->string x) " "
399 (number->string y) " "
404 (apply string-append (map control->string l))
410 (define (stem kern width height depth)
411 (string-append (numbers->string (list kern width height depth))
418 (string-append "(" s ") set" f " "))
421 (define (volta w last)
423 (numbers->string (list w (inexact->exact last)))
425 (define (tuplet dx dy dir)
427 (numbers->string (list dx dy (inexact->exact dir)))
435 ; dispatch on action-name
436 (cond ((eq? action-name 'all-definitions)
439 (define tuplet ,tuplet)
440 (define bracket ,bracket)
441 (define crescendo ,crescendo)
442 (define volta ,volta)
444 (define dashed-slur ,dashed-slur)
445 (define decrescendo ,decrescendo)
446 (define empty ,empty)
447 (define end-output ,end-output)
448 (define font-def ,font-def)
449 (define font-switch ,font-switch)
450 (define generalmeter ,generalmeter)
451 (define header-end ,header-end)
452 (define lily-def ,lily-def)
453 (define header ,header)
454 (define invoke-char ,invoke-char)
455 (define invoke-dim1 ,invoke-dim1)
456 (define placebox ,placebox)
457 (define rulesym ,rulesym)
458 (define start-line ,start-line)
460 (define stop-line ,stop-line)
463 ((eq? action-name 'tuplet) tuplet)
464 ((eq? action-name 'beam) beam)
465 ((eq? action-name 'bracket) bracket)
466 ((eq? action-name 'crescendo) crescendo)
467 ((eq? action-name 'volta) volta)
468 ((eq? action-name 'slur) slur)
469 ((eq? action-name 'dashed-slur) dashed-slur)
470 ((eq? action-name 'decrescendo) decrescendo)
471 (else (error "unknown tag -- PS-SCM " action-name))