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>
8 ; This file contains various routines in Scheme that are easier to
9 ; do here than in C++. At present it is an unorganised mess. Sorry.
12 ; We should repartition the entire scm side of lily in a
13 ; more sane way, using namesspaces/modules?
15 (debug-enable 'backtrace)
19 (use-modules (ice-9 regex))
21 (define (number-pair? x)
22 (and (pair? x) (number? (car x)) (number? (cdr x))))
24 (define (object-type obj)
26 ((dir? obj) "direction")
27 ((number-pair? obj) "pair of numbers")
28 ((ly-input-location? obj) "input location")
29 ((ly-element? obj) "graphic element")
31 ((integer? obj) "integer")
33 ((symbol? obj) "symbol")
34 ((string? obj) "string")
35 ((boolean? obj) "boolean")
36 ((moment? obj) "moment")
37 ((number? obj) "number")
39 ((input-port? obj) "input port")
40 ((output-port? obj) "output port")
41 ((vector? obj) "vector")
42 ((procedure? obj) "procedure")
47 (define (type-name predicate)
49 ((eq? predicate dir?) "direction")
50 ((eq? predicate number-pair?) "pair of numbers")
51 ((eq? predicate ly-input-location?) "input location")
52 ((eq? predicate ly-element?) "graphic element")
53 ((eq? predicate pair?) "pair")
54 ((eq? predicate integer?) "integer")
55 ((eq? predicate list?) "list")
56 ((eq? predicate symbol?) "symbol")
57 ((eq? predicate string?) "string")
58 ((eq? predicate boolean?) "boolean")
59 ((eq? predicate moment?) "moment")
60 ((eq? predicate number?) "number")
61 ((eq? predicate char?) "char")
62 ((eq? predicate input-port?) "input port")
63 ((eq? predicate output-port?) "output port")
64 ((eq? predicate vector?) "vector")
65 ((eq? predicate procedure?) "procedure")
70 ;; The regex module may not be available, or may be broken.
72 (let ((os (string-downcase (vector-ref (uname) 0))))
73 (not (equal? "cygwin" (substring os 0 (min 6 (string-length os)))))))
75 ;; If you have trouble with regex, define #f
77 ;;(define use-regex #f)
79 ;; do nothing in .scm output
80 (define (comment s) "")
82 ;; URG guile-1.3/1.4 compatibility
83 (define (ly-eval x) (eval2 x #f))
85 (define (comment s) "")
91 (define (cons-map f x)
92 (cons (f (car x)) (f (cdr x))))
94 (define (reduce operator list)
95 (if (null? (cdr list)) (car list)
96 (operator (car list) (reduce operator (cdr list)))
101 (define (numbers->string l)
102 (apply string-append (map ly-number->string l)))
104 ; (define (chop-decimal x) (if (< (abs x) 0.001) 0.0 x))
106 (define (number->octal-string x)
107 (let* ((n (inexact->exact x))
108 (n64 (quotient n 64))
109 (n8 (quotient (- n (* n64 64)) 8)))
113 (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
115 (define (inexact->string x radix)
116 (let ((n (inexact->exact x)))
117 (number->string n radix)))
120 (define (control->string c)
121 (string-append (number->string (car c)) " "
122 (number->string (cdr c)) " "))
127 (make-string 1 (integer->char (+ (char->integer #\A) i)))
130 (define (scm-scm action-name)
133 (define security-paranoia #f)
137 (define (find-notehead-symbol duration style)
140 ((harmonic) "0mensural")
142 (string-append (number->string duration)
143 (if (< duration 0) "mensural" "")))
144 ((default) (number->string duration))
146 (string-append (number->string duration) (symbol->string style))))
152 (define (string-encode-integer i)
155 ((< i 0) (string-append "n" (string-encode-integer (- i))))
157 (make-string 1 (integer->char (+ 65 (modulo i 26))))
158 (string-encode-integer (quotient i 26))
163 (define default-script-alist '())
165 (define font-name-alist '())
166 (define (tex-encoded-fontswitch name-mag)
168 (iname-mag (car name-mag))
169 (ename-mag (cdr name-mag))
173 (string-append "magfont"
174 (string-encode-integer
175 (hashq (car ename-mag) 1000000))
177 (string-encode-integer
178 (inexact->exact (* 1000 (cdr ename-mag))))
184 (define (define-fonts internal-external-name-mag-pairs)
185 (set! font-name-alist (map tex-encoded-fontswitch
186 internal-external-name-mag-pairs))
189 (font-load-command (car x) (cdr x)))
190 (map cdr font-name-alist)
194 (define (fontify name-mag-pair exp)
195 (string-append (select-font name-mag-pair)
202 ; Make a function that checks score element for being of a specific type.
203 (define (make-type-checker symbol)
206 ;;(eq? #t (ly-get-elt-property elt symbol))
207 (not (eq? #f (memq symbol (ly-get-elt-property elt 'interfaces))))
210 ;;;;;;;;;;;;;;;;;;; TeX output
211 (define (tex-scm action-name)
216 (define (select-font name-mag-pair)
219 (c (assoc name-mag-pair font-name-alist))
225 (display (object-type (car name-mag-pair)))
226 (display (object-type (caaar font-name-alist)))
228 (ly-warn (string-append
229 "Programming error: No such font known "
230 (car name-mag-pair) " "
231 (number->string (cdr name-mag-pair))
233 "") ; issue no command
234 (string-append "\\" (cddr c)))
239 (define (beam width slope thick)
240 (embedded-ps ((ps-scm 'beam) width slope thick)))
242 (define (bracket arch_angle arch_width arch_height width height arch_thick thick)
243 (embedded-ps ((ps-scm 'bracket) arch_angle arch_width arch_height width height arch_thick thick)))
245 (define (dashed-slur thick dash l)
246 (embedded-ps ((ps-scm 'dashed-slur) thick dash l)))
248 (define (crescendo thick w h cont)
249 (embedded-ps ((ps-scm 'crescendo) thick w h cont)))
252 (string-append "\\char" (inexact->string i 10) " "))
254 (define (dashed-line thick on off dx dy)
255 (embedded-ps ((ps-scm 'dashed-line) thick on off dx dy)))
257 (define (decrescendo thick w h cont)
258 (embedded-ps ((ps-scm 'decrescendo) thick w h cont)))
260 (define (font-load-command name-mag command)
262 "\\font\\" command "="
265 (number->string (inexact->exact (* 1000 (cdr name-mag))))
268 (define (embedded-ps s)
269 (string-append "\\embeddedps{" s "}"))
272 (string-append "% " s))
276 ; uncomment for some stats about lily memory
277 ; (display (gc-stats))
278 (string-append "\n\\EndLilyPondOutput"
282 (define (experimental-on)
285 (define (font-switch i)
289 (define (font-def i s)
291 "\\font" (font-switch i) "=" s "\n"))
297 ;; URG: ly-gulp-file: now we can't use scm output without Lily
299 ;; fixed in 1.3.4 for powerpc -- broken on Windows
300 (regexp-substitute/global #f "\n"
301 (ly-gulp-file "lily.ps") 'pre " %\n" 'post)
302 (ly-gulp-file "lily.ps"))
304 "\\input lilyponddefs\\newdimen\\outputscale \\outputscale=\\mudelapaperoutputscale pt\\turnOnPostScript"))
306 (define (header creator generate)
308 "%created by: " creator generate "\n"))
310 (define (invoke-char s i)
312 "\n\\" s "{" (inexact->string i 10) "}" ))
314 (define (invoke-dim1 s d)
316 "\n\\" s "{" (number->dim d) "}"))
321 ;; need to do something to make this really safe.
323 (define (output-tex-string s)
324 (if security-paranoia
326 (regexp-substitute/global #f "\\\\" s 'pre "$\\backslash$" 'post)
327 (begin (display "warning: not paranoid") (newline) s))
330 (define (lily-def key val)
334 ;; fixed in 1.3.4 for powerpc -- broken on Windows
335 (regexp-substitute/global #f "_"
336 (output-tex-string key) 'pre "X" 'post)
337 (output-tex-string key))
338 "{" (output-tex-string val) "}\n"))
340 (define (number->dim x)
342 (ly-number->string x) " \\outputscale "))
344 (define (placebox x y s)
347 (number->dim y) "}{" (number->dim x) "}{" s "}\n"))
349 (define (bezier-sandwich l thick)
350 (embedded-ps ((ps-scm 'bezier-sandwich) l thick)))
352 (define (start-line ht)
353 (string-append"\\vbox to " (number->dim ht) "{\\hbox{%\n"))
356 "}\\vss}\\interscoreline\n")
357 (define (stop-last-line)
359 (define (filledbox breapth width depth height)
361 "\\kern" (number->dim (- breapth))
362 "\\vrule width " (number->dim (+ breapth width))
363 "depth " (number->dim depth)
364 "height " (number->dim height) " "))
367 (string-append "\\hbox{" (output-tex-string s) "}"))
369 (define (tuplet ht gapx dx dy thick dir)
370 (embedded-ps ((ps-scm 'tuplet) ht gapx dx dy thick dir)))
372 (define (volta h w thick vert_start vert_end)
373 (embedded-ps ((ps-scm 'volta) h w thick vert_start vert_end)))
375 (define (define-origin file line col)
376 ; use this for column positions
377 (string-append "\\special{src:" (number->string line) ":"
378 (number->string col) " " file "}"
379 ;; arg, the clueless take over the mailing list...
380 ; "\\special{-****-These-warnings-are-harmless-***}"
381 ; "\\special{-****-PLEASE-read-http://appel.lilypond.org/wiki/index.php3?PostProcessing-****}"
385 ;(string-append "\\special{src:" (number->string line) " " file "}")
387 ; no origin info: return empty string
389 ; no-origin not yet supported by Xdvi
390 (define (no-origin) "")
393 ;; The procedures listed below form the public interface of TeX-scm.
394 ;; (should merge the 2 lists)
395 (cond ((eq? action-name 'all-definitions)
397 (define font-load-command ,font-load-command)
399 (define bezier-sandwich ,bezier-sandwich)
400 (define bracket ,bracket)
402 (define crescendo ,crescendo)
403 (define dashed-line ,dashed-line)
404 (define dashed-slur ,dashed-slur)
405 (define decrescendo ,decrescendo)
406 (define end-output ,end-output)
407 (define experimental-on ,experimental-on)
408 (define filledbox ,filledbox)
409 (define font-def ,font-def)
410 (define font-switch ,font-switch)
411 (define header-end ,header-end)
412 (define lily-def ,lily-def)
413 (define header ,header)
414 (define invoke-char ,invoke-char)
415 (define invoke-dim1 ,invoke-dim1)
416 (define placebox ,placebox)
417 (define select-font ,select-font)
418 (define start-line ,start-line)
419 (define stop-line ,stop-line)
420 (define stop-last-line ,stop-last-line)
422 (define tuplet ,tuplet)
423 (define volta ,volta)
424 (define define-origin ,define-origin)
425 (define no-origin ,no-origin)
428 ((eq? action-name 'beam) beam)
429 ((eq? action-name 'tuplet) tuplet)
430 ((eq? action-name 'bracket) bracket)
431 ((eq? action-name 'crescendo) crescendo)
432 ((eq? action-name 'dashed-line) dashed-line)
433 ((eq? action-name 'dashed-slur) dashed-slur)
434 ((eq? action-name 'decrescendo) decrescendo)
435 ((eq? action-name 'end-output) end-output)
436 ((eq? action-name 'experimental-on) experimental-on)
437 ((eq? action-name 'font-def) font-def)
438 ((eq? action-name 'font-switch) font-switch)
439 ((eq? action-name 'header-end) header-end)
440 ((eq? action-name 'lily-def) lily-def)
441 ((eq? action-name 'header) header)
442 ((eq? action-name 'invoke-char) invoke-char)
443 ((eq? action-name 'invoke-dim1) invoke-dim1)
444 ((eq? action-name 'placebox) placebox)
445 ((eq? action-name 'bezier-sandwich) bezier-sandwich)
446 ((eq? action-name 'start-line) start-line)
447 ((eq? action-name 'stem) stem)
448 ((eq? action-name 'stop-line) stop-line)
449 ((eq? action-name 'stop-last-line) stop-last-line)
450 ((eq? action-name 'volta) volta)
451 (else (error "unknown tag -- PS-TEX " action-name))
457 (define (ps-scm action-name)
459 ;; alist containing fontname -> fontcommand assoc (both strings)
460 (define font-alist '())
461 (define font-count 0)
462 (define current-font "")
465 (define (cached-fontname i)
468 (make-string 1 (integer->char (+ 65 i)))))
471 (define (select-font name-mag-pair)
474 (c (assoc name-mag-pair font-name-alist))
479 (display name-mag-pair)
480 (display font-name-alist)
481 (ly-warn (string-append
482 "Programming error: No such font known " (car name-mag-pair))
483 (number->string (cdr name-mag-pair))
486 "") ; issue no command
487 (string-append " " (cdr c) " "))
490 (define (font-load-command name-mag command)
494 (symbol->string (car name-mag))
496 (number->string (cdr name-mag))
497 " 1000 div 12 mul scalefont setfont } bind def "
501 (define (beam width slope thick)
503 (numbers->string (list width slope thick)) " draw_beam" ))
506 (string-append "% " s))
508 (define (bracket arch_angle arch_width arch_height width height arch_thick thick)
510 (numbers->string (list arch_angle arch_width arch_height width height arch_thick thick)) " draw_bracket" ))
513 (invoke-char " show" i))
515 (define (crescendo thick w h cont )
517 (numbers->string (list w h (inexact->exact cont) thick))
520 ;; what the heck is this interface ?
521 (define (dashed-slur thick dash l)
523 (apply string-append (map control->string l))
524 (number->string thick)
526 (number->string dash)
528 (number->string (* 10 thick)) ;UGH. 10 ?
529 " ] 0 draw_dashed_slur"))
531 (define (dashed-line thick on off dx dy)
537 (number->string thick)
542 " ] 0 draw_dashed_line"))
544 (define (decrescendo thick w h cont)
546 (numbers->string (list w h (inexact->exact cont) thick))
547 " draw_decrescendo"))
553 (define (experimental-on) "")
555 (define (filledbox breapth width depth height)
556 (string-append (numbers->string (list breapth width depth height))
560 (define (font-def i s)
563 (substring s 0 (- (string-length s) 4))
564 " findfont 12 scalefont setfont} bind def \n"))
566 (define (font-switch i)
567 (string-append (font i) " "))
571 ;; URG: now we can't use scm output without Lily
572 (ly-gulp-file "lilyponddefs.ps")
573 " {exch pop //systemdict /run get exec} "
574 (ly-gulp-file "lily.ps")
575 "{ exch pop //systemdict /run get exec } "
578 (define (lily-def key val)
580 (if (string=? (substring key 0 (min (string-length "mudelapaper") (string-length key))) "mudelapaper")
581 (string-append "/" key " {" val "} bind def\n")
582 (string-append "/" key " (" val ") def\n")
586 (define (header creator generate)
589 "%%Creator: " creator generate "\n"))
591 (define (invoke-char s i)
593 "(\\" (inexact->string i 8) ") " s " " ))
595 (define (invoke-dim1 s d)
597 (number->string (* d (/ 72.27 72))) " " s ))
599 (define (placebox x y s)
601 (number->string x) " " (number->string y) " {" s "} placebox "))
603 (define (bezier-sandwich l thick)
605 (apply string-append (map control->string l))
606 (number->string thick)
607 " draw_bezier_sandwich"))
609 (define (start-line height)
612 (define (stem breapth width depth height)
613 (string-append (numbers->string (list breapth width depth height))
620 (string-append "(" s ") show "))
623 (define (volta h w thick vert_start vert_end)
625 (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
628 (define (tuplet ht gap dx dy thick dir)
630 (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
638 (define (define-origin a b c ) "")
639 (define (no-origin) "")
642 (cond ((eq? action-name 'all-definitions)
645 (define tuplet ,tuplet)
646 (define bracket ,bracket)
648 (define crescendo ,crescendo)
649 (define volta ,volta)
650 (define bezier-sandwich ,bezier-sandwich)
651 (define dashed-line ,dashed-line)
652 (define dashed-slur ,dashed-slur)
653 (define decrescendo ,decrescendo)
654 (define end-output ,end-output)
655 (define experimental-on ,experimental-on)
656 (define filledbox ,filledbox)
657 (define font-def ,font-def)
658 (define font-switch ,font-switch)
659 (define header-end ,header-end)
660 (define lily-def ,lily-def)
661 (define font-load-command ,font-load-command)
662 (define header ,header)
663 (define invoke-char ,invoke-char)
664 (define invoke-dim1 ,invoke-dim1)
665 (define placebox ,placebox)
666 (define select-font ,select-font)
667 (define start-line ,start-line)
669 (define stop-line ,stop-line)
670 (define stop-last-line ,stop-line)
672 (define no-origin ,no-origin)
673 (define define-origin ,define-origin)
675 ((eq? action-name 'tuplet) tuplet)
676 ((eq? action-name 'beam) beam)
677 ((eq? action-name 'bezier-sandwich) bezier-sandwich)
678 ((eq? action-name 'bracket) bracket)
679 ((eq? action-name 'char) char)
680 ((eq? action-name 'crescendo) crescendo)
681 ((eq? action-name 'dashed-line) dashed-line)
682 ((eq? action-name 'dashed-slur) dashed-slur)
683 ((eq? action-name 'decrescendo) decrescendo)
684 ((eq? action-name 'experimental-on) experimental-on)
685 ((eq? action-name 'filledbox) filledbox)
686 ((eq? action-name 'select-font) select-font)
687 ((eq? action-name 'volta) volta)
688 (else (error "unknown tag -- PS-SCM " action-name))
693 (define (arg->string arg)
694 (cond ((number? arg) (inexact->string arg 10))
695 ((string? arg) (string-append "\"" arg "\""))
696 ((symbol? arg) (string-append "\"" (symbol->string arg) "\""))))
699 (define (func name . args)
705 (map (lambda (x) (string-append " " (arg->string x))) args)))
713 (define (gulp-file name)
714 (let* ((file (open-input-file name))
715 (text (read-delimited "" file)))
719 ;; urg: Use when standalone, do:
720 ;; (define ly-gulp-file scm-gulp-file)
721 (define (scm-gulp-file name)
723 (cons (string-append (getenv 'LILYPONDPREFIX) "/ly")
724 (cons (string-append (getenv 'LILYPONDPREFIX) "/ps")
726 (let ((path (%search-load-path name)))
731 (define (scm-tex-output)
732 (ly-eval (tex-scm 'all-definitions)))
734 (define (scm-ps-output)
735 (ly-eval (ps-scm 'all-definitions)))
737 (define (scm-as-output)
738 (ly-eval (as-scm 'all-definitions)))
740 (define (index-cell cell dir)
758 (eval-string (ly-gulp-file "interface.scm"))
759 (eval-string (ly-gulp-file "slur.scm"))
760 (eval-string (ly-gulp-file "font.scm"))
761 (eval-string (ly-gulp-file "auto-beam.scm"))
762 (eval-string (ly-gulp-file "generic-property.scm"))
763 (eval-string (ly-gulp-file "basic-properties.scm"))
764 (eval-string (ly-gulp-file "chord-names.scm"))
765 (eval-string (ly-gulp-file "element-descriptions.scm"))