]> git.donarmstrong.com Git - lilypond.git/blob - scm/lily.scm
release: 1.2.5
[lilypond.git] / scm / lily.scm
1 ; lily.scm -- implement Scheme output routines for TeX and PostScript
2 ;
3 ;  source file of the GNU LilyPond music typesetter
4
5 ; (c) 1998 Jan Nieuwenhuizen <janneke@gnu.org>
6
7
8 ;(debug-enable 'backtrace)
9
10 ;;; library funtions
11 (define
12   (xnumbers->string l)
13   (string-append 
14    (map (lambda (n) (string-append (number->string n ) " ")) l)))
15
16 (define (reduce operator list)
17       (if (null? (cdr list)) (car list)
18           (operator (car list) (reduce operator (cdr list)))
19           )
20       )
21
22
23 (define (glue-2-strings a b) (string-append a " " b))
24
25 (define
26   (numbers->string l)
27   (reduce glue-2-strings (map number->string l)))
28
29 (define (chop-decimal x) (if (< (abs x) 0.001) 0.0 x))
30
31 (define (number->octal-string x)
32   (let* ((n (inexact->exact x))
33          (n64 (quotient n 64))
34          (n8 (quotient (- n (* n64 64)) 8)))
35     (string-append
36      (number->string n64)
37      (number->string n8)
38      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
39
40 (define (inexact->string x radix)
41   (let ((n (inexact->exact x)))
42     (number->string n radix)))
43
44
45 (define
46   (control->string c)
47   (string-append
48    (string-append (number->string (car c)) " ")
49    (string-append (number->string (cadr c)) " ")))
50
51
52 (define (font i)
53   (string-append
54    "font"
55    (make-string 1 (integer->char (+ (char->integer #\A) i)))
56    ))
57
58
59
60 (define (scm-scm action-name)
61   1)
62
63 (define security-paranoia #f)
64
65
66 ;; See documentation of Item::visibility_lambda_
67 (define (postbreak_only_visibility d) (if (= d 1) '(#f . #f) '(#t . #t)))
68 (define (spanbar_non_postbreak_visibility d) (if (= d -1) '(#t . #t) '(#f . #f)))
69
70 (define (non_postbreak_visibility d) (if (= d 1) '(#t . #t) '(#f . #f)))
71 (define (non_prebreak_visibility d) (if (= d -1) '(#t . #t) '(#f . #f)))
72
73
74 ;; Score_span_bars are only visible at start of line
75 ;; i.e. if break_dir == RIGHT == 1
76 (define Span_bar_engraver_visibility non_postbreak_visibility)
77 (define mark-visibility non_prebreak_visibility)
78 (define Span_score_bar_engraver_visibility postbreak_only_visibility)
79 (define Piano_bar_engraver_visibility postbreak_only_visibility)
80 (define Staff_group_bar_engraver_visibility postbreak_only_visibility)
81
82 ;; Spacing constants for prefatory matter.
83 ;;
84 ;; rules for this spacing are much more complicated than this. See [Wanske] page 126 -- 134, [Ross] pg 143 -- 147
85 ;;
86 ;;
87
88 (define space-alist
89  '(
90    (("" "Clef_item") . (minimum_space 1.0))
91    (("" "Staff_bar") . (minimum_space 0.0))
92    (("" "Clef_item") . (minimum_space 1.0))
93    (("" "Key_item") . (minimum_space 0.5))
94    (("" "Span_bar") . (extra_space 0.0))
95    (("" "Time_signature") . (extra_space 0.0))
96    (("" "begin-of-note") . (minimum_space 1.5))
97    (("Clef_item" "Key_item") . (minimum_space 4.0))
98    (("Key_item" "Time_signature") . (extra_space 1.0))
99    (("Clef_item"  "Time_signature") . (minimum_space 3.5))
100    (("Staff_bar" "Clef_item") .   (minimum_space 1.0))
101    (("Clef_item"  "Staff_bar") .  (minimum_space 3.7))
102    (("Time_signature" "Staff_bar") .  (minimum_space 2.0))
103    (("Key_item"  "Staff_bar") .  (extra_space 1.0))
104    (("Span_bar" "Clef_item") .   (extra_space 1.0))
105    (("Clef_item"  "Span_bar") . (minimum_space 3.7))
106    (("Time_signature" "Span_bar") . (minimum_space 2.0))
107    (("Key_item"  "Span_bar") . (minimum_space 2.5))
108    (("Staff_bar" "Time_signature") . (minimum_space 1.5)) ;double check this.
109    (("Time_signature" "begin-of-note") . (extra_space 2.0)) ;double check this.
110    (("Key_item" "begin-of-note") . (extra_space 2.5))
111    (("Staff_bar" "begin-of-note") . (extra_space 1.0))
112    (("Clef_item" "begin-of-note") . (minimum_space 5.0))
113    (("" "Breathing_sign") . (minimum_space 0.0))
114    (("Breathing_sign" "Key_item") . (minimum_space 1.5))
115    (("Breathing_sign" "begin-of-note") . (minimum_space 1.0))
116    (("Breathing_sign" "Staff_bar") . (minimum_space 1.5))
117    (("Breathing_sign" "Clef_item") . (minimum_space 2.0))
118    )
119 )
120  
121 (define (break-align-spacer this next)
122   (let ((entry (assoc `(,this ,next) space-alist)))
123     (if entry
124         (cdr entry)
125         (begin (ly-warn (string-append "Unknown spacing pair `" this "', `" next "'"))
126                '(minimum_space 0.0)))))
127   
128         
129
130 ;;;;;;;; TeX
131
132 (define cmr-alist 
133   '(("bold" . "cmbx") 
134     ("dynamic" . "feta-din") 
135     ("finger" . "feta-nummer") 
136     ("typewriter" . "cmtt") 
137     ("italic" . "cmti") 
138     ("roman" . "cmr") 
139     ("large" . "cmbx") 
140     ("Large" . "cmbx") 
141     ("mark" . "feta-nummer") 
142     ("number" . "feta-nummer") 
143     ("volta" . "feta-nummer"))
144 )
145
146 (define script-alist '())
147 (define (articulation-to-scriptdef a)
148   (assoc a script-alist)
149   )
150
151 ;; Map style names to TeX font names.  Return false if 
152 ;; no font name found. 
153 (define (style-to-cmr s)
154   (assoc s cmr-alist )
155   )
156
157
158 (define (tex-scm action-name)
159
160   (define (unknown) 
161     "%\n\\unknown%\n")
162
163   (define font-alist '())
164   (define font-count 0)
165   (define current-font "")
166   (define (clear-fontcache)
167     (begin
168       (set! font-alist '())
169       (set! font-count 0)
170       (set! current-font "")))
171   
172   (define (cached-fontname i)
173     (string-append
174      "\\lilyfont"
175      (make-string 1 (integer->char (+ 65 i)))))
176
177   (define (select-font font-name magnification)
178       (if (not (equal? font-name current-font))
179           (let* ((font-cmd (assoc font-name font-alist)))
180             (set! current-font font-name)
181             (if (eq? font-cmd #f)
182                 (begin
183                   (set! font-cmd (cached-fontname font-count))
184                   (set! font-alist (acons font-name font-cmd font-alist))
185                   (set! font-count (+ 1 font-count))
186                   (if (equal? font-name "")
187                       (error "Empty fontname -- SELECT-FONT"))
188                   (if (> magnification 0)
189                       (string-append "\\font" font-cmd "=" font-name 
190                                      " scaled \\magstep " 
191                                      (number->string magnification) font-cmd)
192                       (string-append "\\font" font-cmd "=" font-name font-cmd)))
193                 
194                 (cdr font-cmd)))
195           ""                            ;no switch needed
196           ))
197   
198   (define (beam width slope thick)
199     (embedded-ps ((ps-scm 'beam) width slope thick)))
200
201   (define (bracket h)
202     (embedded-ps ((ps-scm 'bracket) h)))
203
204   (define (dashed-slur thick dash l)
205     (embedded-ps ((ps-scm 'dashed-slur)  thick dash l)))
206
207   (define (crescendo thick w h cont)
208     (embedded-ps ((ps-scm 'crescendo) thick w h cont)))
209
210   (define (char i)
211     (string-append "\\char" (inexact->string i 10) " "))
212   
213   (define (decrescendo thick w h cont)
214     (embedded-ps ((ps-scm 'decrescendo) thick w h cont)))
215
216    ;This sets CTM so that you get to the currentpoint
217   ; by executing a 0 0 moveto
218        
219   (define (embedded-ps s)
220     (string-append "\\embeddedps{" s "}"))
221
222   (define (end-output) 
223     "\n\\EndLilyPondOutput")
224   
225   (define (experimental-on)
226     "")
227
228   (define (font-switch i)
229     (string-append
230      "\\" (font i) "\n"))
231
232   (define (font-def i s)
233     (string-append
234      "\\font" (font-switch i) "=" s "\n"))
235
236   (define (header-end)
237     (string-append
238      "\\special{! "
239      (regexp-substitute/global #f "\n" (ly-gulp-file "lily.ps") 'pre " %\n" 'post)
240      "}"
241      "\\input lilyponddefs \\turnOnPostScript"))
242
243   (define (header creator generate) 
244     (string-append
245      "%created by: " creator generate "\n"))
246
247   (define (invoke-char s i)
248     (string-append 
249      "\n\\" s "{" (inexact->string i 10) "}" ))
250
251   (define (invoke-dim1 s d)
252     (string-append
253      "\n\\" s "{" (number->dim d) "}"))
254   (define (pt->sp x)
255     (* 65536 x))
256   
257   ;;
258   ;; need to do something to make this really safe.
259   ;;
260   (define (output-tex-string s)
261       (if security-paranoia
262           (regexp-substitute/global #f "\\\\" s 'pre "$\\backslash$" 'post)
263           s))
264       
265
266   (define (lily-def key val)
267     (string-append
268      "\\def\\" (output-tex-string key) "{" (output-tex-string val) "}\n"))
269
270   (define (number->dim x)
271     (string-append 
272      (number->string  (chop-decimal x)) " pt "))
273
274   (define (placebox x y s) 
275     (string-append 
276      "\\placebox{"
277      (number->dim y) "}{" (number->dim x) "}{" s "}"))
278
279   ;;;;
280   (define (pianobrace y staffht)
281     (let* ((step 1.0)
282            (minht (* 2 staffht))
283            (maxht (* 7 minht))
284            )
285       (string-append
286        (select-font (string-append "feta-braces" (number->string (inexact->exact staffht))) 0)
287        (char (max 0 (/  (- (min y (- maxht step)) minht) step))))
288       )
289     )
290
291
292   (define (bezier-sandwich l thick)
293     (embedded-ps ((ps-scm 'bezier-sandwich) l thick)))
294
295
296   (define (start-line ht)
297     (begin
298       (clear-fontcache)
299       (string-append"\\vbox to " (number->dim ht) "{\\hbox{%\n"))
300     )
301   (define (stop-line) 
302     "}\\vss}\\interscoreline")
303   (define (stop-last-line)
304     "}\\vss}")
305   (define (filledbox breapth width depth height) 
306     (string-append 
307      "\\kern" (number->dim (- breapth))
308      "\\vrule width " (number->dim (+ breapth width))
309      "depth " (number->dim depth)
310      "height " (number->dim height) " "))
311
312   (define (text s)
313     (string-append "\\hbox{" (output-tex-string s) "}"))
314   
315   (define (tuplet ht gapx dx dy thick dir)
316     (embedded-ps ((ps-scm 'tuplet) ht gapx dx dy thick dir)))
317
318   (define (volta h w thick vert_start vert_end)
319     (embedded-ps ((ps-scm 'volta) h w thick vert_start vert_end)))
320
321   ;; TeX
322   ;; The procedures listed below form the public interface of TeX-scm.
323   ;; (should merge the 2 lists)
324   (cond ((eq? action-name 'all-definitions)
325          `(begin
326             (define beam ,beam)
327             (define bezier-sandwich ,bezier-sandwich)
328             (define bracket ,bracket)
329             (define char ,char)
330             (define crescendo ,crescendo)
331             (define dashed-slur ,dashed-slur) 
332             (define decrescendo ,decrescendo) 
333             (define end-output ,end-output)
334             (define experimental-on ,experimental-on)
335             (define filledbox ,filledbox)
336             (define font-def ,font-def)
337             (define font-switch ,font-switch)
338             (define header-end ,header-end)
339             (define lily-def ,lily-def)
340             (define header ,header) 
341             (define invoke-char ,invoke-char) 
342             (define invoke-dim1 ,invoke-dim1)
343             (define pianobrace ,pianobrace)
344             (define placebox ,placebox)
345             (define select-font ,select-font)
346             (define start-line ,start-line)
347             (define stop-line ,stop-line)
348             (define stop-last-line ,stop-last-line)
349             (define text ,text)
350             (define tuplet ,tuplet)
351             (define volta ,volta)
352             ))
353
354         ((eq? action-name 'beam) beam)
355         ((eq? action-name 'tuplet) tuplet)
356         ((eq? action-name 'bracket) bracket)
357         ((eq? action-name 'crescendo) crescendo)
358         ((eq? action-name 'dashed-slur) dashed-slur) 
359         ((eq? action-name 'decrescendo) decrescendo) 
360         ((eq? action-name 'end-output) end-output)
361         ((eq? action-name 'experimental-on) experimental-on)
362         ((eq? action-name 'font-def) font-def)
363         ((eq? action-name 'font-switch) font-switch)
364         ((eq? action-name 'header-end) header-end)
365         ((eq? action-name 'lily-def) lily-def)
366         ((eq? action-name 'header) header) 
367         ((eq? action-name 'invoke-char) invoke-char) 
368         ((eq? action-name 'invoke-dim1) invoke-dim1)
369         ((eq? action-name 'placebox) placebox)
370         ((eq? action-name 'bezier-sandwich) bezier-sandwich)
371         ((eq? action-name 'start-line) start-line)
372         ((eq? action-name 'stem) stem)
373         ((eq? action-name 'stop-line) stop-line)
374         ((eq? action-name 'stop-last-line) stop-last-line)
375         ((eq? action-name 'volta) volta)
376         (else (error "unknown tag -- PS-TEX " action-name))
377         )
378   )
379
380 ;;;;;;;;;;;; PS
381 (define (ps-scm action-name)
382
383
384   ;; alist containing fontname -> fontcommand assoc (both strings)
385   (define font-alist '())
386   (define font-count 0)
387   (define current-font "")
388   (define (clear-fontcache)
389     (begin
390       (set! font-alist '())
391       (set! font-count 0)
392       (set! current-font "")))
393   
394   (define (cached-fontname i)
395     (string-append
396      "lilyfont"
397      (make-string 1 (integer->char (+ 65 i)))))
398     
399   (define (mag-to-size m)
400     (number->string (case m 
401                       ('0 12)
402                       ('1 12)
403                       ('2 14) ; really: 14.400
404                       ('3 17) ; really: 17.280
405                       ('4 21) ; really: 20.736
406                       ('5 24) ; really: 24.888
407                       ('6 30) ; really: 29.856
408                       )))
409   
410   (define (select-font font-name magnification)
411       (if (not (equal? font-name current-font))
412           (begin
413             (set! current-font font-name)
414             (define font-cmd (assoc font-name font-alist))
415             (if (eq? font-cmd #f)
416                 (begin
417                   (set! font-cmd (cached-fontname font-count))
418                   (set! font-alist (acons font-name font-cmd font-alist))
419                   (set! font-count (+ 1 font-count))
420                   (string-append "\n/" font-cmd " {/"
421                                  font-name " findfont " 
422                                  (mag-to-size magnification)
423                                  " scalefont setfont} bind def \n"
424                                  font-cmd " \n"))
425                 (string-append (cdr font-cmd) " ")))
426           ; font-name == current-font no switch needed
427           ""                            
428           ))
429                   
430   (define (beam width slope thick)
431     (string-append
432      (numbers->string (list width slope thick)) " draw_beam" ))
433
434   (define (bracket h)
435     (invoke-dim1 " draw_bracket" h))
436
437   (define (char i)
438     (invoke-char " show" i))
439
440   (define (crescendo thick w h cont )
441     (string-append 
442      (numbers->string (list w h (inexact->exact cont) thick))
443      " draw_crescendo"))
444
445   (define (dashed-slur thick dash l)
446     (string-append 
447      (apply string-append (map control->string l)) 
448      (number->string thick) 
449      " [ "
450      (if (> 1 dash)
451          (number->string (- (* thick dash) thick))
452          "0")
453      " "
454      (number->string (* 2 thick))
455      " ] 0 draw_dashed_slur"))
456
457   (define (decrescendo thick w h cont)
458     (string-append 
459      (numbers->string (list w h (inexact->exact cont) thick))
460      " draw_decrescendo"))
461
462
463   (define (end-output)
464     "\nshowpage\n")
465   
466   (define (experimental-on) "")
467   
468   (define (filledbox breapth width depth height) 
469     (string-append (numbers->string (list breapth width depth height))
470                    " draw_box" ))
471
472   ;; obsolete?
473   (define (font-def i s)
474     (string-append
475      "\n/" (font i) " {/" 
476      (substring s 0 (- (string-length s) 4))
477      " findfont 12 scalefont setfont} bind def \n"))
478
479   (define (font-switch i)
480     (string-append (font i) " "))
481
482   (define (header-end)
483     (string-append
484      (ly-gulp-file "lilyponddefs.ps")
485      " {exch pop //systemdict /run get exec} "
486      (ly-gulp-file "lily.ps")
487      "{ exch pop //systemdict /run get exec } "
488     ))
489   
490   (define (lily-def key val)
491
492      (if (string=? (substring key 0 (min (string-length "mudelapaper") (string-length key))) "mudelapaper")
493          (string-append "/" key " {" val "} bind def\n")
494          (string-append "/" key " (" val ") def\n")
495          )
496      )
497
498   (define (header creator generate) 
499     (string-append
500      "%!PS-Adobe-3.0\n"
501      "%%Creator: " creator generate "\n"))
502   
503   (define (invoke-char s i)
504     (string-append 
505      "(\\" (inexact->string i 8) ") " s " " ))
506   
507   (define (invoke-dim1 s d) 
508     (string-append
509      (number->string (* d  (/ 72.27 72))) " " s ))
510
511   (define (placebox x y s) 
512     (string-append 
513      (number->string x) " " (number->string y) " {" s "} placebox "))
514
515   (define (pianobrace y staffht)
516     (let* ((step 1.0)
517            (minht (* 2 staffht))
518            (maxht (* 7 minht))
519            )
520       (string-append
521        (select-font (string-append "feta-braces" (number->string (inexact->exact staffht))) 0)
522        (char (max 0 (/  (- (min y (- maxht step)) minht) step))))
523       )
524     )
525
526
527   (define (bezier-sandwich l thick)
528     (string-append 
529      (apply string-append (map control->string l))
530      (number->string  thick)
531      " draw_bezier_sandwich"))
532
533   (define (start-line height)
534     (begin
535       (clear-fontcache)
536       "\nstart_line {\n"))
537   
538   (define (stem breapth width depth height) 
539     (string-append (numbers->string (list breapth width depth height))
540                    " draw_box" ))
541
542   (define (stop-line)
543       "}\nstop_line\n")
544
545   (define (text s)
546     (string-append "(" s ") show  "))
547
548
549   (define (volta h w thick vert_start vert_end)
550     (string-append 
551      (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
552      " draw_volta"))
553
554   (define (tuplet ht gap dx dy thick dir)
555     (string-append 
556      (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
557      " draw_tuplet"))
558
559
560   (define (unknown) 
561     "\n unknown\n")
562
563
564   ;; PS
565   (cond ((eq? action-name 'all-definitions)
566          `(begin
567             (define beam ,beam)
568             (define tuplet ,tuplet)
569             (define bracket ,bracket)
570             (define char ,char)
571             (define crescendo ,crescendo)
572             (define volta ,volta)
573             (define bezier-sandwich ,bezier-sandwich)
574             (define dashed-slur ,dashed-slur) 
575             (define decrescendo ,decrescendo) 
576             (define end-output ,end-output)
577             (define experimental-on ,experimental-on)
578             (define filledbox ,filledbox)
579             (define font-def ,font-def)
580             (define font-switch ,font-switch)
581             (define pianobrace ,pianobrace)
582             (define header-end ,header-end)
583             (define lily-def ,lily-def)
584             (define header ,header) 
585             (define invoke-char ,invoke-char) 
586             (define invoke-dim1 ,invoke-dim1)
587             (define placebox ,placebox)
588             (define select-font ,select-font)
589             (define start-line ,start-line)
590             (define stem ,stem)
591             (define stop-line ,stop-line)
592             (define stop-last-line ,stop-line)
593             (define text ,text)
594             ))
595         ((eq? action-name 'tuplet) tuplet)
596         ((eq? action-name 'beam) beam)
597         ((eq? action-name 'bezier-sandwich) bezier-sandwich)
598         ((eq? action-name 'bracket) bracket)
599         ((eq? action-name 'char) char)
600         ((eq? action-name 'crescendo) crescendo)
601         ((eq? action-name 'dashed-slur) dashed-slur) 
602         ((eq? action-name 'decrescendo) decrescendo)
603         ((eq? action-name 'experimental-on) experimental-on)
604         ((eq? action-name 'filledbox) filledbox)
605         ((eq? action-name 'select-font) select-font)
606         ((eq? action-name 'volta) volta)
607         (else (error "unknown tag -- PS-SCM " action-name))
608         )
609   )
610
611                                         ;
612 ; Russ McManus, <mcmanus@IDT.NET>  
613
614 ; I use the following, which should definitely be provided somewhere
615 ; in guile, but isn't, AFAIK:
616
617
618
619 (define (hash-table-for-each fn ht)
620   (do ((i 0 (+ 1 i)))
621       ((= i (vector-length ht)))
622     (do ((alist (vector-ref ht i) (cdr alist)))
623         ((null? alist) #t)
624       (fn (car (car alist)) (cdr (car alist))))))
625
626 (define (hash-table-map fn ht)
627   (do ((i 0 (+ 1 i))
628        (ret-ls '()))
629       ((= i (vector-length ht)) (reverse ret-ls))
630     (do ((alist (vector-ref ht i) (cdr alist)))
631         ((null? alist) #t)
632       (set! ret-ls (cons (fn (car (car alist)) (cdr (car alist))) ret-ls)))))
633
634
635 ;;;; print a SCM expression.  Isn't this part of the std lib?
636
637 (define (scmlist->string exp)
638   (cond
639    ((pair? (cdr exp)) (string-append (scm->string (car exp)) " " (scmlist->string (cdr exp))))
640    ((eq? '() (cdr exp)) (string-append (scm->string (car exp)) ")"))
641    (else (string-append (scm->string (car exp)) " . " (scm->string (cdr exp)) ")"))
642    ))
643
644 (define (scm->string exp)
645   (cond
646    ((pair? exp) (string-append "(" (scmlist->string exp)))
647    ((number? exp) (number->string exp))
648    ((symbol? exp) (symbol->string exp))
649    ((string? exp) (string-append "\"" exp "\""))
650    ))
651
652 (define (test-scm->string)
653 (list (scmlist->string '(a))
654 (scmlist->string '(a b))
655 (scmlist->string '(a b . c))
656
657
658 (scm->string '(a))
659 (scm->string '(a b ))
660 (scm->string '(a b . c))
661 (scm->string '(a b (c . d)))
662 (scm->string '(a "bla" (c . 1.5)))
663 )
664 )