1 ;;; lily.scm -- implement Scheme output routines for TeX and PostScript
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 1998--2003 Jan Nieuwenhuizen <janneke@gnu.org>
6 ;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
11 (use-modules (ice-9 regex))
15 ;; debugging evaluator is slower.
18 ;(debug-enable 'backtrace)
19 (read-enable 'positions)
22 (define-public (line-column-location line col file)
23 "Print an input location, including column number ."
24 (string-append (number->string line) ":"
25 (number->string col) " " file)
28 (define-public (line-location line col file)
29 "Print an input location, without column number ."
30 (string-append (number->string line) " " file)
33 (define-public point-and-click #f)
35 ;; cpp hack to get useful error message
36 (define ifdef "First run this through cpp.")
37 (define ifndef "First run this through cpp.")
41 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
45 (define-public START -1)
46 (define-public STOP 1)
47 (define-public LEFT -1)
48 (define-public RIGHT 1)
50 (define-public DOWN -1)
51 (define-public CENTER 0)
53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
54 ;; lily specific variables.
55 (define-public default-script-alist '())
57 (define-public security-paranoia #f)
59 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
60 ;;; Unassorted utility functions.
65 (define (uniqued-alist alist acc)
67 (if (assoc (caar alist) acc)
68 (uniqued-alist (cdr alist) acc)
69 (uniqued-alist (cdr alist) (cons (car alist) acc)))))
72 (define (assoc-get key alist)
73 "Return value if KEY in ALIST, else #f."
74 (let ((entry (assoc key alist)))
75 (if entry (cdr entry) #f)))
77 (define (assoc-get-default key alist default)
78 "Return value if KEY in ALIST, else DEFAULT."
79 (let ((entry (assoc key alist)))
80 (if entry (cdr entry) default)))
83 (define-public (uniqued-alist alist acc)
85 (if (assoc (caar alist) acc)
86 (uniqued-alist (cdr alist) acc)
87 (uniqued-alist (cdr alist) (cons (car alist) acc)))))
89 (define-public (alist<? x y)
90 (string<? (symbol->string (car x))
91 (symbol->string (car y))))
96 "Return tail element of LST."
97 (car (last-pair lst)))
100 (define (flatten-list lst)
104 (if (pair? (car lst))
105 (append (flatten-list (car lst)) (flatten-list (cdr lst)))
106 (cons (car lst) (flatten-list (cdr lst))))
109 (define (list-minus a b)
110 "Return list of elements in A that are not in B."
113 (if (member (car a) b)
114 (list-minus (cdr a) b)
115 (cons (car a) (list-minus (cdr a) b)))
119 ;; why -list suffix (see reduce-list)
120 (define-public (filter-list pred? list)
121 "return that part of LIST for which PRED is true.
123 TODO: rewrite using accumulator. Now it takes O(n) stack. "
126 (let* ((rest (filter-list pred? (cdr list))))
127 (if (pred? (car list))
128 (cons (car list) rest)
131 (define-public (filter-out-list pred? list)
132 "return that part of LIST for which PRED is false."
134 (let* ((rest (filter-out-list pred? (cdr list))))
135 (if (not (pred? (car list)))
136 (cons (car list) rest)
140 (define (first-n n lst)
141 "Return first N elements of LST"
144 (cons (car lst) (first-n (- n 1) (cdr lst)))
147 (define-public (uniq-list list)
149 (if (null? (cdr list))
151 (if (equal? (car list) (cadr list))
152 (uniq-list (cdr list))
153 (cons (car list) (uniq-list (cdr list)))))))
155 (define (butfirst-n n lst)
156 "Return all but first N entries of LST"
159 (butfirst-n (- n 1) (cdr lst))
163 (define (split-at predicate l)
164 "Split L = (a_1 a_2 ... a_k b_1 ... b_k)
165 into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k)
166 Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
167 L1 is copied, L2 not.
169 (split-at (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))"
174 (define (inner-split predicate l acc)
178 (set-car! acc (cons (car l) (car acc)))
180 ((predicate (car l) (cadr l))
181 (set-car! acc (cons (car l) (car acc)))
182 (inner-split predicate (cdr l) acc))
184 (set-car! acc (cons (car l) (car acc)))
185 (set-cdr! acc (cdr l))
192 (inner-split predicate l c)
193 (set-car! c (reverse! (car c)))
198 (define-public (split-list l sep?)
201 (display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) )
203 ((a b c) (d e f) (g))
207 (define (split-one sep? l acc)
208 "Split off the first parts before separator and return both parts.
216 (split-one sep? (cdr l) (cons (car l) acc))
222 (let* ((c (split-one sep? l '())))
223 (cons (reverse! (car c) '()) (split-list (cdr c) sep?))
229 (define-public (range x y)
230 "Produce a list of integers starting at Y with X elements."
233 (cons y (range (- x 1) (+ y 1)))
238 (define-public (interval-length x)
239 "Length of the number-pair X, when an interval"
240 (max 0 (- (cdr x) (car x)))
244 (define (other-axis a)
245 (remainder (+ a 1) 2))
248 (define-public (widen-interval iv amount)
249 (cons (- (car iv) amount)
253 (define-public (write-me message x)
254 "Return X. Display MESSAGE and write X. Handy for debugging, possibly turned off."
255 (display message) (write x) (newline) x)
258 (define (index-cell cell dir)
263 (define (cons-map f x)
264 "map F to contents of X"
265 (cons (f (car x)) (f (cdr x))))
268 (define-public (reduce operator list)
269 "reduce OP [A, B, C, D, ... ] =
272 (if (null? (cdr list)) (car list)
273 (operator (car list) (reduce operator (cdr list)))))
275 (define (take-from-list-until todo gathered crit?)
276 "return (G, T), where (reverse G) + T = GATHERED + TODO, and the last of G
277 is the first to satisfy CRIT
279 (take-from-list-until '(1 2 3 4 5) '() (lambda (x) (eq? x 3)))
286 (if (crit? (car todo))
287 (cons (cons (car todo) gathered) (cdr todo))
288 (take-from-list-until (cdr todo) (cons (car todo) gathered) crit?)
292 (define-public (list-insert-separator list between)
293 "Create new list, inserting BETWEEN between elements of LIST"
296 (if (null? (cdr list))
299 (cons between (list-insert-separator (cdr list) between)))
307 ;; TODO : make sep optional.
308 (define-public (string-join str-list sep)
309 "append the list of strings in STR-LIST, joining them with SEP"
311 (apply string-append (list-insert-separator str-list sep))
314 (define-public (pad-string-to str wid)
315 (string-append str (make-string (max (- wid (string-length str)) 0) #\ ))
325 (define-public (!= l r)
328 (define-public (ly:load x)
330 (fn (%search-load-path x))
334 (format (current-error-port) "[~A]" fn))
335 (primitive-load fn)))
338 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
340 (use-modules (scm output-tex)
342 (scm output-ascii-script)
344 (scm output-sodipodi)
350 ("tex" . ("TeX output. The default output form." ,tex-output-expression))
351 ("ps" . ("Direct postscript. Requires setting GS_LIB and GS_FONTPATH" ,ps-output-expression))
352 ("scm" . ("Scheme dump: debug scheme molecule expressions" ,write))
353 ("as" . ("Asci-script. Postprocess with as2txt to get ascii art" ,as-output-expression))
354 ("sketch" . ("Bare bones Sketch output." ,sketch-output-expression))
355 ("sodipodi" . ("Bare bones Sodipodi output." ,sodipodi-output-expression))
356 ("pdftex" . ("PDFTeX output. Was last seen nonfunctioning." ,pdftex-output-expression))
360 (define (document-format-dumpers)
363 (display (string-append (pad-string-to 5 (car x)) (cadr x) "\n"))
367 (define-public (find-dumper format )
369 ((d (assoc format output-alist)))
373 (scm-error "Could not find dumper for format ~s" format))
376 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
381 '("define-music-types.scm"
384 "chord-ignatzek-names.scm"
386 "double-plus-new-chord-name.scm"
390 "music-functions.scm"
391 "define-music-properties.scm"
395 "define-translator-properties.scm"
396 "translation-functions.scm"
406 "define-grob-properties.scm"
408 "define-grob-interfaces.scm"
415 (set! type-p-name-alist
417 (,ly:dir? . "direction")
418 (,scheme? . "any type")
419 (,number-pair? . "pair of numbers")
420 (,ly:input-location? . "input location")
421 (,ly:grob? . "grob (GRaphical OBject)")
422 (,grob-list? . "list of grobs")
423 (,ly:duration? . "duration")
425 (,integer? . "integer")
427 (,symbol? . "symbol")
428 (,string? . "string")
429 (,boolean? . "boolean")
430 (,ly:pitch? . "pitch")
431 (,ly:moment? . "moment")
432 (,ly:dimension? . "dimension, in staff space")
433 (,ly:input-location? . "input location")
434 (,music-list? . "list of music")
435 (,ly:music? . "music")
436 (,number? . "number")
438 (,input-port? . "input port")
439 (,output-port? . "output port")
440 (,vector? . "vector")
441 (,procedure? . "procedure")
442 (,boolean-or-symbol? . "boolean or symbol")
443 (,number-or-string? . "number or string")
444 (,markup? . "markup")
445 (,markup-list? . "list of markups")
446 (,number-or-grob? . "number or grob")