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 ; This file contains various routines in Scheme that are easier to
10 ; do here than in C++. At present it is an unorganised mess. Sorry.
14 ; We should repartition the entire scm side of lily in a
15 ; more sane way, using namesspaces/modules?
17 (debug-enable 'backtrace)
21 (use-modules (ice-9 regex))
23 (define (number-pair? x)
24 (and (pair? x) (number? (car x)) (number? (cdr x))))
26 (define (type-name predicate)
28 ((eq? predicate dir?) "direction")
29 ((eq? predicate number-pair?) "pair of numbers")
30 ((eq? predicate ly-input-location?) "input location")
31 ((eq? predicate ly-element?) "graphic element")
32 ((eq? predicate pair?) "pair")
33 ((eq? predicate integer?) "integer")
34 ((eq? predicate list?) "list")
35 ((eq? predicate symbol?) "symbol")
36 ((eq? predicate string?) "string")
37 ((eq? predicate boolean?) "boolean")
38 ((eq? predicate moment?) "moment")
39 ((eq? predicate number?) "number")
40 ((eq? predicate char?) "char")
41 ((eq? predicate input-port?) "input port")
42 ((eq? predicate output-port?) "output port")
43 ((eq? predicate vector?) "vector")
44 ((eq? predicate procedure?) "procedure")
49 ;; The regex module may not be available, or may be broken.
51 (let ((os (string-downcase (vector-ref (uname) 0))))
52 (not (equal? "cygwin" (substring os 0 (min 6 (string-length os)))))))
54 ;; If you have trouble with regex, define #f
56 ;;(define use-regex #f)
58 ;; do nothing in .scm output
59 (define (comment s) "")
61 ;; URG guile-1.3/1.4 compatibility
62 (define (ly-eval x) (eval2 x #f))
64 (define (comment s) "")
70 (define (cons-map f x)
71 (cons (f (car x)) (f (cdr x))))
73 (define (reduce operator list)
74 (if (null? (cdr list)) (car list)
75 (operator (car list) (reduce operator (cdr list)))
80 (define (numbers->string l)
81 (apply string-append (map ly-number->string l)))
83 ; (define (chop-decimal x) (if (< (abs x) 0.001) 0.0 x))
85 (define (number->octal-string x)
86 (let* ((n (inexact->exact x))
88 (n8 (quotient (- n (* n64 64)) 8)))
92 (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
94 (define (inexact->string x radix)
95 (let ((n (inexact->exact x)))
96 (number->string n radix)))
99 (define (control->string c)
100 (string-append (number->string (car c)) " "
101 (number->string (cdr c)) " "))
106 (make-string 1 (integer->char (+ (char->integer #\A) i)))
109 (define (scm-scm action-name)
112 (define security-paranoia #f)
116 (define (find-notehead-symbol duration style)
119 ((harmonic) "0mensural")
121 (string-append (number->string duration)
122 (if (< duration 0) "mensural" "")))
123 ((default) (number->string duration))
125 (string-append (number->string duration) (symbol->string style)))))
130 ;; this is silly, can't we use something like
131 ;; roman-0, roman-1 roman+1 ?
134 ("brace" . "feta-braces")
135 ("default" . "cmr10")
136 ("dynamic" . "feta-din")
140 ("typewriter" . "cmtt")
147 ("mark" . "feta-nummer")
148 ("finger" . "feta-nummer")
149 ("timesig" . "feta-nummer")
150 ("number" . "feta-nummer")
151 ("volta" . "feta-nummer"))
154 (define (string-encode-integer i)
157 ((< i 0) (string-append "n" (string-encode-integer (- i))))
159 (make-string 1 (integer->char (+ 65 (modulo i 26))))
160 (string-encode-integer (quotient i 26))
167 (cdr (assoc i '((-4 . 482)
180 (define default-script-alist '())
182 (define font-name-alist '())
183 (define (font-command name-mag)
185 (string-append "magfont"
186 (string-encode-integer (hashq (car name-mag) 1000000))
188 (string-encode-integer (cdr name-mag)))
192 (define (define-fonts names)
193 (set! font-name-alist (map font-command names))
196 (font-load-command (car x) (cdr x))) font-name-alist)
199 (define (fontify name exp)
200 (string-append (select-font name)
207 ; Make a function that checks score element for being of a specific type.
208 (define (make-type-checker symbol)
211 ;;(eq? #t (ly-get-elt-property elt symbol))
212 (not (eq? #f (memq symbol (ly-get-elt-property elt 'interfaces))))
215 ;;;;;;;;;;;;;;;;;;; TeX output
216 (define (tex-scm action-name)
221 (define (select-font font-name-symbol)
224 (c (assoc font-name-symbol font-name-alist))
229 (ly-warn (string-append
230 "Programming error: No such font known " (car font-name-symbol)))
231 "") ; issue no command
232 (string-append "\\" (cdr c)))
237 (define (beam width slope thick)
238 (embedded-ps ((ps-scm 'beam) width slope thick)))
240 (define (bracket arch_angle arch_width arch_height width height arch_thick thick)
241 (embedded-ps ((ps-scm 'bracket) arch_angle arch_width arch_height width height arch_thick thick)))
243 (define (dashed-slur thick dash l)
244 (embedded-ps ((ps-scm 'dashed-slur) thick dash l)))
246 (define (crescendo thick w h cont)
247 (embedded-ps ((ps-scm 'crescendo) thick w h cont)))
250 (string-append "\\char" (inexact->string i 10) " "))
252 (define (dashed-line thick on off dx dy)
253 (embedded-ps ((ps-scm 'dashed-line) thick on off dx dy)))
255 (define (decrescendo thick w h cont)
256 (embedded-ps ((ps-scm 'decrescendo) thick w h cont)))
258 (define (font-load-command name-mag command)
260 "\\font\\" command "="
261 (symbol->string (car name-mag))
263 (number->string (magstep (cdr name-mag)))
266 (define (embedded-ps s)
267 (string-append "\\embeddedps{" s "}"))
270 (string-append "% " s))
274 ; uncomment for some stats about lily memory
275 ; (display (gc-stats))
276 (string-append "\n\\EndLilyPondOutput"
280 (define (experimental-on)
283 (define (font-switch i)
287 (define (font-def i s)
289 "\\font" (font-switch i) "=" s "\n"))
295 ;; URG: ly-gulp-file: now we can't use scm output without Lily
297 ;; fixed in 1.3.4 for powerpc -- broken on Windows
298 (regexp-substitute/global #f "\n"
299 (ly-gulp-file "lily.ps") 'pre " %\n" 'post)
300 (ly-gulp-file "lily.ps"))
302 "\\input lilyponddefs \\turnOnPostScript"))
304 (define (header creator generate)
306 "%created by: " creator generate "\n"))
308 (define (invoke-char s i)
310 "\n\\" s "{" (inexact->string i 10) "}" ))
312 (define (invoke-dim1 s d)
314 "\n\\" s "{" (number->dim d) "}"))
319 ;; need to do something to make this really safe.
321 (define (output-tex-string s)
322 (if security-paranoia
324 (regexp-substitute/global #f "\\\\" s 'pre "$\\backslash$" 'post)
325 (begin (display "warning: not paranoid") (newline) s))
328 (define (lily-def key val)
332 ;; fixed in 1.3.4 for powerpc -- broken on Windows
333 (regexp-substitute/global #f "_"
334 (output-tex-string key) 'pre "X" 'post)
335 (output-tex-string key))
336 "{" (output-tex-string val) "}\n"))
338 (define (number->dim x)
340 (ly-number->string x) " pt "))
342 (define (placebox x y s)
345 (number->dim y) "}{" (number->dim x) "}{" s "}\n"))
347 (define (bezier-sandwich l thick)
348 (embedded-ps ((ps-scm 'bezier-sandwich) l thick)))
350 (define (start-line ht)
351 (string-append"\\vbox to " (number->dim ht) "{\\hbox{%\n"))
354 "}\\vss}\\interscoreline\n")
355 (define (stop-last-line)
357 (define (filledbox breapth width depth height)
359 "\\kern" (number->dim (- breapth))
360 "\\vrule width " (number->dim (+ breapth width))
361 "depth " (number->dim depth)
362 "height " (number->dim height) " "))
365 (string-append "\\hbox{" (output-tex-string s) "}"))
367 (define (tuplet ht gapx dx dy thick dir)
368 (embedded-ps ((ps-scm 'tuplet) ht gapx dx dy thick dir)))
370 (define (volta h w thick vert_start vert_end)
371 (embedded-ps ((ps-scm 'volta) h w thick vert_start vert_end)))
373 (define (define-origin file line col)
374 ; use this for column positions
375 (string-append "\\special{src:" (number->string line) ":"
376 (number->string col) " " file "}"
377 ;; arg, the clueless take over the mailing list...
378 ; "\\special{-****-These-warnings-are-harmless-***}"
379 ; "\\special{-****-PLEASE-read-http://appel.lilypond.org/wiki/index.php3?PostProcessing-****}"
383 ;(string-append "\\special{src:" (number->string line) " " file "}")
385 ; no origin info: return empty string
387 ; no-origin not yet supported by Xdvi
388 (define (no-origin) "")
391 ;; The procedures listed below form the public interface of TeX-scm.
392 ;; (should merge the 2 lists)
393 (cond ((eq? action-name 'all-definitions)
395 (define font-load-command ,font-load-command)
397 (define bezier-sandwich ,bezier-sandwich)
398 (define bracket ,bracket)
400 (define crescendo ,crescendo)
401 (define dashed-line ,dashed-line)
402 (define dashed-slur ,dashed-slur)
403 (define decrescendo ,decrescendo)
404 (define end-output ,end-output)
405 (define experimental-on ,experimental-on)
406 (define filledbox ,filledbox)
407 (define font-def ,font-def)
408 (define font-switch ,font-switch)
409 (define header-end ,header-end)
410 (define lily-def ,lily-def)
411 (define header ,header)
412 (define invoke-char ,invoke-char)
413 (define invoke-dim1 ,invoke-dim1)
414 (define placebox ,placebox)
415 (define select-font ,select-font)
416 (define start-line ,start-line)
417 (define stop-line ,stop-line)
418 (define stop-last-line ,stop-last-line)
420 (define tuplet ,tuplet)
421 (define volta ,volta)
422 (define define-origin ,define-origin)
423 (define no-origin ,no-origin)
426 ((eq? action-name 'beam) beam)
427 ((eq? action-name 'tuplet) tuplet)
428 ((eq? action-name 'bracket) bracket)
429 ((eq? action-name 'crescendo) crescendo)
430 ((eq? action-name 'dashed-line) dashed-line)
431 ((eq? action-name 'dashed-slur) dashed-slur)
432 ((eq? action-name 'decrescendo) decrescendo)
433 ((eq? action-name 'end-output) end-output)
434 ((eq? action-name 'experimental-on) experimental-on)
435 ((eq? action-name 'font-def) font-def)
436 ((eq? action-name 'font-switch) font-switch)
437 ((eq? action-name 'header-end) header-end)
438 ((eq? action-name 'lily-def) lily-def)
439 ((eq? action-name 'header) header)
440 ((eq? action-name 'invoke-char) invoke-char)
441 ((eq? action-name 'invoke-dim1) invoke-dim1)
442 ((eq? action-name 'placebox) placebox)
443 ((eq? action-name 'bezier-sandwich) bezier-sandwich)
444 ((eq? action-name 'start-line) start-line)
445 ((eq? action-name 'stem) stem)
446 ((eq? action-name 'stop-line) stop-line)
447 ((eq? action-name 'stop-last-line) stop-last-line)
448 ((eq? action-name 'volta) volta)
449 (else (error "unknown tag -- PS-TEX " action-name))
455 (define (ps-scm action-name)
457 ;; alist containing fontname -> fontcommand assoc (both strings)
458 (define font-alist '())
459 (define font-count 0)
460 (define current-font "")
463 (define (cached-fontname i)
466 (make-string 1 (integer->char (+ 65 i)))))
468 (define (mag-to-size m)
469 (number->string (case m
472 (2 14) ; really: 14.400
473 (3 17) ; really: 17.280
474 (4 21) ; really: 20.736
475 (5 24) ; really: 24.888
476 (6 30) ; really: 29.856
480 (define (select-font font-name-symbol)
483 (c (assoc font-name-symbol font-name-alist))
488 (ly-warn (string-append
489 "Programming error: No such font known " (car font-name-symbol)))
490 "") ; issue no command
491 (string-append " " (cdr c) " "))
496 (define (font-load-command name-mag command)
500 (symbol->string (car name-mag))
502 (number->string (magstep (cdr name-mag)))
503 " 1000 div 12 mul scalefont setfont } bind def "
507 (define (beam width slope thick)
509 (numbers->string (list width slope thick)) " draw_beam" ))
512 (string-append "% " s))
514 (define (bracket arch_angle arch_width arch_height width height arch_thick thick)
516 (numbers->string (list arch_angle arch_width arch_height width height arch_thick thick)) " draw_bracket" ))
519 (invoke-char " show" i))
521 (define (crescendo thick w h cont )
523 (numbers->string (list w h (inexact->exact cont) thick))
526 ;; what the heck is this interface ?
527 (define (dashed-slur thick dash l)
529 (apply string-append (map control->string l))
530 (number->string thick)
532 (number->string dash)
534 (number->string (* 10 thick)) ;UGH. 10 ?
535 " ] 0 draw_dashed_slur"))
537 (define (dashed-line thick on off dx dy)
543 (number->string thick)
548 " ] 0 draw_dashed_line"))
550 (define (decrescendo thick w h cont)
552 (numbers->string (list w h (inexact->exact cont) thick))
553 " draw_decrescendo"))
559 (define (experimental-on) "")
561 (define (filledbox breapth width depth height)
562 (string-append (numbers->string (list breapth width depth height))
566 (define (font-def i s)
569 (substring s 0 (- (string-length s) 4))
570 " findfont 12 scalefont setfont} bind def \n"))
572 (define (font-switch i)
573 (string-append (font i) " "))
577 ;; URG: now we can't use scm output without Lily
578 (ly-gulp-file "lilyponddefs.ps")
579 " {exch pop //systemdict /run get exec} "
580 (ly-gulp-file "lily.ps")
581 "{ exch pop //systemdict /run get exec } "
584 (define (lily-def key val)
586 (if (string=? (substring key 0 (min (string-length "mudelapaper") (string-length key))) "mudelapaper")
587 (string-append "/" key " {" val "} bind def\n")
588 (string-append "/" key " (" val ") def\n")
592 (define (header creator generate)
595 "%%Creator: " creator generate "\n"))
597 (define (invoke-char s i)
599 "(\\" (inexact->string i 8) ") " s " " ))
601 (define (invoke-dim1 s d)
603 (number->string (* d (/ 72.27 72))) " " s ))
605 (define (placebox x y s)
607 (number->string x) " " (number->string y) " {" s "} placebox "))
609 (define (bezier-sandwich l thick)
611 (apply string-append (map control->string l))
612 (number->string thick)
613 " draw_bezier_sandwich"))
615 (define (start-line height)
618 (define (stem breapth width depth height)
619 (string-append (numbers->string (list breapth width depth height))
626 (string-append "(" s ") show "))
629 (define (volta h w thick vert_start vert_end)
631 (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
634 (define (tuplet ht gap dx dy thick dir)
636 (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
644 (define (define-origin a b c ) "")
645 (define (no-origin) "")
648 (cond ((eq? action-name 'all-definitions)
651 (define tuplet ,tuplet)
652 (define bracket ,bracket)
654 (define crescendo ,crescendo)
655 (define volta ,volta)
656 (define bezier-sandwich ,bezier-sandwich)
657 (define dashed-line ,dashed-line)
658 (define dashed-slur ,dashed-slur)
659 (define decrescendo ,decrescendo)
660 (define end-output ,end-output)
661 (define experimental-on ,experimental-on)
662 (define filledbox ,filledbox)
663 (define font-def ,font-def)
664 (define font-switch ,font-switch)
665 (define header-end ,header-end)
666 (define lily-def ,lily-def)
667 (define font-load-command ,font-load-command)
668 (define header ,header)
669 (define invoke-char ,invoke-char)
670 (define invoke-dim1 ,invoke-dim1)
671 (define placebox ,placebox)
672 (define select-font ,select-font)
673 (define start-line ,start-line)
675 (define stop-line ,stop-line)
676 (define stop-last-line ,stop-line)
678 (define no-origin ,no-origin)
679 (define define-origin ,define-origin)
681 ((eq? action-name 'tuplet) tuplet)
682 ((eq? action-name 'beam) beam)
683 ((eq? action-name 'bezier-sandwich) bezier-sandwich)
684 ((eq? action-name 'bracket) bracket)
685 ((eq? action-name 'char) char)
686 ((eq? action-name 'crescendo) crescendo)
687 ((eq? action-name 'dashed-line) dashed-line)
688 ((eq? action-name 'dashed-slur) dashed-slur)
689 ((eq? action-name 'decrescendo) decrescendo)
690 ((eq? action-name 'experimental-on) experimental-on)
691 ((eq? action-name 'filledbox) filledbox)
692 ((eq? action-name 'select-font) select-font)
693 ((eq? action-name 'volta) volta)
694 (else (error "unknown tag -- PS-SCM " action-name))
699 (define (arg->string arg)
700 (cond ((number? arg) (inexact->string arg 10))
701 ((string? arg) (string-append "\"" arg "\""))
702 ((symbol? arg) (string-append "\"" (symbol->string arg) "\""))))
704 (define (func name . args)
710 (map (lambda (x) (string-append " " (arg->string x))) args)))
719 (define (as-scm action-name)
721 (define (beam width slope thick)
723 (func "set-line-char" "#")
724 (func "rline-to" width (* width slope))
728 (define (bezier-sandwich l thick)
735 (dy (- (cdr c3) (cdr c0)))
737 (c1-dx (- (car c1) x))
738 (c1-line-y (+ (cdr c0) (* c1-dx rc)))
739 (dir (if (< c1-line-y (cdr c1)) 1 -1))
740 (y (+ -1 (* dir (max (* dir (cdr c0)) (* dir (cdr c3)))))))
742 (func "rmove-to" x y)
743 (func "put" (if (< 0 dir) "/" "\\\\"))
744 (func "rmove-to" 1 (if (< 0 dir) 1 0))
745 (func "set-line-char" "_")
746 (func "h-line" (- dx 1))
747 (func "rmove-to" (- dx 1) (if (< 0 dir) -1 0))
748 (func "put" (if (< 0 dir) "\\\\" "/"))))))
750 (define (bracket arch_angle arch_width arch_height width height arch_thick thick)
752 (func "rmove-to" (+ width 1) (- (/ height -2) 1))
754 (func "set-line-char" "|")
755 (func "rmove-to" 0 1)
756 (func "v-line" (+ height 1))
757 (func "rmove-to" 0 (+ height 1))
764 (define (define-origin a b c ) "")
769 (define (experimental-on)
772 (define (filledbox breapth width depth height)
773 (let ((dx (+ width breapth))
774 (dy (+ depth height)))
776 (func "rmove-to" (* -1 breapth) (* -1 depth))
779 (func "set-line-char"
780 (if (<= dx 1) "|" "#"))
783 (func "set-line-char"
784 (if (<= dy 1) "-" "="))
785 (func "h-line" dx))))))
787 (define (font-load-command name-mag command)
788 (func "load-font" (car name-mag) (magstep (cdr name-mag))))
790 (define (header creator generate)
791 (func "header" creator generate))
796 ;; urg: this is good for half of as2text's execution time
797 (define (xlily-def key val)
798 (string-append "(define " key " " (arg->string val) ")\n"))
800 (define (lily-def key val)
802 (or (equal? key "mudelapaperlinewidth")
803 (equal? key "mudelapaperstaffheight"))
804 (string-append "(define " key " " (arg->string val) ")\n")
807 (define (no-origin) "")
809 (define (placebox x y s)
810 (let ((ey (inexact->exact y)))
811 (string-append "(move-to " (number->string (inexact->exact x)) " "
812 (if (= 0.5 (- (abs y) (abs ey)))
817 (define (select-font font-name-symbol)
818 (let* ((c (assoc font-name-symbol font-name-alist)))
823 "Programming error: No such font known "
824 (car font-name-symbol)))
825 "") ; issue no command
826 (func "select-font" (car font-name-symbol)))))
828 (define (start-line height)
829 (func "start-line" height))
837 (define (tuplet ht gap dx dy thick dir) "")
839 (define (volta h w thick vert-start vert-end)
842 (func "set-line-char" "|")
843 (func "rmove-to" 0 -4)
844 ;; definition strange-way around
848 (func "rmove-to" 1 h)
849 (func "set-line-char" "_")
850 (func "h-line" (- w 1))
851 (func "set-line-char" "|")
854 (func "rmove-to" (- w 1) (* -1 h))
855 (func "v-line" (* -1 h)))
858 (cond ((eq? action-name 'all-definitions)
861 (define bracket ,bracket)
863 (define define-origin ,define-origin)
864 ;;(define crescendo ,crescendo)
865 (define bezier-sandwich ,bezier-sandwich)
866 ;;(define dashed-slur ,dashed-slur)
867 ;;(define decrescendo ,decrescendo)
868 (define end-output ,end-output)
869 (define experimental-on ,experimental-on)
870 (define filledbox ,filledbox)
871 ;;(define font-def ,font-def)
872 (define font-load-command ,font-load-command)
873 ;;(define font-switch ,font-switch)
874 (define header ,header)
875 (define header-end ,header-end)
876 (define lily-def ,lily-def)
877 ;;(define invoke-char ,invoke-char)
878 ;;(define invoke-dim1 ,invoke-dim1)
879 (define no-origin ,no-origin)
880 (define placebox ,placebox)
881 (define select-font ,select-font)
882 (define start-line ,start-line)
883 ;;(define stem ,stem)
884 (define stop-line ,stop-line)
885 (define stop-last-line ,stop-line)
887 (define tuplet ,tuplet)
888 (define volta ,volta)
890 ((eq? action-name 'tuplet) tuplet)
891 ;;((eq? action-name 'beam) beam)
892 ;;((eq? action-name 'bezier-sandwich) bezier-sandwich)
893 ;;((eq? action-name 'bracket) bracket)
894 ((eq? action-name 'char) char)
895 ;;((eq? action-name 'crescendo) crescendo)
896 ;;((eq? action-name 'dashed-slur) dashed-slur)
897 ;;((eq? action-name 'decrescendo) decrescendo)
898 ;;((eq? action-name 'experimental-on) experimental-on)
899 ((eq? action-name 'filledbox) filledbox)
900 ((eq? action-name 'select-font) select-font)
901 ;;((eq? action-name 'volta) volta)
902 (else (error "unknown tag -- MUSA-SCM " action-name))
907 (define (gulp-file name)
908 (let* ((port (open-file name "r"))
909 (content (let loop ((text ""))
910 (let ((line (read-line port)))
911 (if (or (eof-object? line)
914 (loop (string-append text line "\n")))))))
918 ;; urg: Use when standalone, do:
919 ;; (define ly-gulp-file scm-gulp-file)
920 (define (scm-gulp-file name)
922 (cons (string-append (getenv 'LILYPONDPREFIX) "/ly")
923 (cons (string-append (getenv 'LILYPONDPREFIX) "/ps")
925 (let ((path (%search-load-path name)))
930 (define (scm-tex-output)
931 (ly-eval (tex-scm 'all-definitions)))
933 (define (scm-ps-output)
934 (ly-eval (ps-scm 'all-definitions)))
936 (define (scm-as-output)
937 (ly-eval (as-scm 'all-definitions)))
939 (define (index-cell cell dir)
957 (eval-string (ly-gulp-file "interface.scm"))
958 (eval-string (ly-gulp-file "slur.scm"))
959 (eval-string (ly-gulp-file "font.scm"))
960 (eval-string (ly-gulp-file "generic-property.scm"))
961 (eval-string (ly-gulp-file "basic-properties.scm"))
962 (eval-string (ly-gulp-file "chord-names.scm"))
963 (eval-string (ly-gulp-file "element-descriptions.scm"))