]> git.donarmstrong.com Git - lilypond.git/blob - scm/lily.scm
* lily/my-lily-lexer.cc (My_lily_lexer): don't crash
[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--2003 Jan Nieuwenhuizen <janneke@gnu.org>
6 ;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
7
8 ;;; Library functions
9
10
11 (use-modules (ice-9 regex)
12              (srfi srfi-1)              ;lists
13              (srfi srfi-13)             ;strings
14              )
15
16 ;;; General settings
17 ;;; debugging evaluator is slower.  This should
18 ;;; have a more sensible default.
19
20
21
22 (debug-enable 'debug)
23 ;(debug-enable 'backtrace)
24 (read-enable 'positions)
25
26
27 (define-public (line-column-location line col file)
28   "Print an input location, including column number ."
29   (string-append (number->string line) ":"
30                  (number->string col) " " file)
31   )
32
33 (define-public (line-location line col file)
34   "Print an input location, without column number ."
35   (string-append (number->string line) " " file)
36   )
37
38 (define-public point-and-click #f)
39
40 (define-public (lilypond-version)
41   (string-join
42    (map (lambda (x) (if (symbol? x)
43                         (symbol->string x)
44                         (number->string x)))
45                 (ly:version))
46    "."))
47
48
49
50 ;; cpp hack to get useful error message
51 (define ifdef "First run this through cpp.")
52 (define ifndef "First run this through cpp.")
53
54
55
56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
57
58 (define-public X 0)
59 (define-public Y 1)
60 (define-public START -1)
61 (define-public STOP 1)
62 (define-public LEFT -1)
63 (define-public RIGHT 1)
64 (define-public UP 1)
65 (define-public DOWN -1)
66 (define-public CENTER 0)
67
68 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
69 ;; lily specific variables.
70 (define-public default-script-alist '())
71
72 (define-public security-paranoia #f)
73
74 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
75 ;;; Unassorted utility functions.
76
77
78 ;;;;;;;;;;;;;;;;
79 ; alist
80 (define (uniqued-alist  alist acc)
81   (if (null? alist) acc
82       (if (assoc (caar alist) acc)
83           (uniqued-alist (cdr alist) acc)
84           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
85
86
87 (define (assoc-get key alist)
88   "Return value if KEY in ALIST, else #f."
89   (let ((entry (assoc key alist)))
90     (if entry (cdr entry) #f)))
91   
92 (define (assoc-get-default key alist default)
93   "Return value if KEY in ALIST, else DEFAULT."
94   (let ((entry (assoc key alist)))
95     (if entry (cdr entry) default)))
96
97
98 (define-public (uniqued-alist  alist acc)
99   (if (null? alist) acc
100       (if (assoc (caar alist) acc)
101           (uniqued-alist (cdr alist) acc)
102           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
103
104 (define-public (alist<? x y)
105   (string<? (symbol->string (car x))
106             (symbol->string (car y))))
107
108
109
110 (define (chain-assoc x alist-list)
111   (if (null? alist-list)
112       #f
113       (let* ((handle (assoc x (car alist-list))))
114         (if (pair? handle)
115             handle
116             (chain-assoc x (cdr alist-list))))))
117
118
119 (define (map-alist-vals func list)
120   "map FUNC over the vals of  LIST, leaving the keys."
121   (if (null?  list)
122       '()
123       (cons (cons  (caar list) (func (cdar list)))
124             (map-alist-vals func (cdr list)))
125       ))
126
127 (define (map-alist-keys func list)
128   "map FUNC over the keys of an alist LIST, leaving the vals. "
129   (if (null?  list)
130       '()
131       (cons (cons (func (caar list)) (cdar list))
132             (map-alist-keys func (cdr list)))
133       ))
134  
135
136
137 ;;;;;;;;;;;;;;;;
138 ; list
139
140 (define (flatten-list lst)
141   "Unnest LST" 
142   (if (null? lst)
143       '()
144       (if (pair? (car lst))
145           (append (flatten-list (car lst)) (flatten-list  (cdr lst)))
146           (cons (car lst) (flatten-list (cdr lst))))
147   ))
148
149 (define (list-minus a b)
150   "Return list of elements in A that are not in B."
151   (lset-difference eq? a b))
152
153
154 ;; TODO: use the srfi-1 partition function.
155 (define-public (uniq-list list)
156   "Uniq LIST, assuming that it is sorted"
157   (if (null? list) '()
158       (if (null? (cdr list))
159           list
160           (if (equal? (car list) (cadr list))
161               (uniq-list (cdr list))
162               (cons (car list) (uniq-list (cdr list)))))))
163
164 (define (split-at-predicate predicate l)
165  "Split L = (a_1 a_2 ... a_k b_1 ... b_k)
166 into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k) 
167 Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
168 L1 is copied, L2 not.
169
170 (split-at-predicate (lambda (x y) (= (- y x) 2))  '(1 3 5 9 11) (cons '() '()))"
171 ;; "
172
173 ;; KUT EMACS MODE.
174
175   (define (inner-split predicate l acc)
176   (cond
177    ((null? l) acc)
178    ((null? (cdr l))
179     (set-car! acc (cons (car l) (car acc)))
180     acc)
181    ((predicate (car l) (cadr l))
182     (set-car! acc (cons (car l) (car acc)))
183     (inner-split predicate (cdr l) acc))
184    (else
185     (set-car! acc (cons (car l) (car acc)))
186     (set-cdr! acc (cdr l))
187     acc)
188
189   ))
190  (let*
191     ((c (cons '() '()))
192      )
193   (inner-split predicate l  c)
194   (set-car! c (reverse! (car c))) 
195   c)
196 )
197
198
199 (define-public (split-list l sep?)
200 "
201 (display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) )
202 =>
203 ((a b c) (d e f) (g))
204
205 "
206 ;; " KUT EMACS.
207
208 (define (split-one sep?  l acc)
209   "Split off the first parts before separator and return both parts."
210   (if (null? l)
211       (cons acc '())
212       (if (sep? (car l))
213           (cons acc (cdr l))
214           (split-one sep? (cdr l) (cons (car l) acc))
215           )
216       ))
217
218 (if (null? l)
219     '()
220     (let* ((c (split-one sep? l '())))
221       (cons (reverse! (car c) '()) (split-list (cdr c) sep?))
222       )))
223
224
225 (define-public (interval-length x)
226   "Length of the number-pair X, when an interval"
227   (max 0 (- (cdr x) (car x)))
228   )
229   
230
231 (define (other-axis a)
232   (remainder (+ a 1) 2))
233   
234
235 (define-public (interval-widen iv amount)
236    (cons (- (car iv) amount)
237          (+ (cdr iv) amount)))
238
239
240 (define-public (interval-union i1 i2)
241    (cons (min (car i1) (car i2))
242          (max (cdr i1) (cdr i2))))
243
244
245 (define-public (write-me message x)
246   "Return X.  Display MESSAGE and write X.  Handy for debugging, possibly turned off."
247   (display message) (write x) (newline) x)
248 ;;  x)
249
250 (define (index-cell cell dir)
251   (if (equal? dir 1)
252       (cdr cell)
253       (car cell)))
254
255 (define (cons-map f x)
256   "map F to contents of X"
257   (cons (f (car x)) (f (cdr x))))
258
259
260 (define-public (list-insert-separator lst between)
261   "Create new list, inserting BETWEEN between elements of LIST"
262   (define (conc x y )
263     (if (eq? y #f)
264         (list x)
265         (cons x  (cons between y))
266         ))
267   (fold-right conc #f lst))
268
269 ;;;;;;;;;;;;;;;;
270 ; other
271 (define (sign x)
272   (if (= x 0)
273       0
274       (if (< x 0) -1 1)))
275
276 (define-public (!= l r)
277   (not (= l r)))
278
279 (define-public (ly:load x)
280   (let* (
281          (fn (%search-load-path x))
282
283          )
284     (if (ly:verbose)
285         (format (current-error-port) "[~A]" fn))
286     (primitive-load fn)))
287
288
289 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
290 ;;  output
291 (use-modules (scm output-tex)
292              (scm output-ps)
293              (scm output-ascii-script)
294              (scm output-sketch)
295              (scm output-sodipodi)
296              (scm output-pdftex)
297              )
298
299 (define output-alist
300   `(
301     ("tex" . ("TeX output. The default output form." ,tex-output-expression))
302     ("ps" . ("Direct postscript. Requires setting GS_LIB and GS_FONTPATH" ,ps-output-expression))
303     ("scm" . ("Scheme dump: debug scheme molecule expressions" ,write))
304     ("as" . ("Asci-script. Postprocess with as2txt to get ascii art"  ,as-output-expression))
305     ("sketch" . ("Bare bones Sketch output." ,sketch-output-expression))
306     ("sodipodi" . ("Bare bones Sodipodi output." ,sodipodi-output-expression))
307     ("pdftex" . ("PDFTeX output. Was last seen nonfunctioning." ,pdftex-output-expression))
308     ))
309
310
311 (define (document-format-dumpers)
312   (map
313    (lambda (x)
314      (display (string-append  (pad-string-to 5 (car x)) (cadr x) "\n"))
315      output-alist)
316    ))
317
318 (define-public (find-dumper format )
319   (let*
320       ((d (assoc format output-alist)))
321     
322     (if (pair? d)
323         (caddr d)
324         (scm-error "Could not find dumper for format ~s" format))
325     ))
326
327 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
328 ;; other files.
329
330 (map ly:load
331                                         ; load-from-path
332      '("define-music-types.scm"
333        "output-lib.scm"
334        "c++.scm"
335        "chord-ignatzek-names.scm"
336        "chord-entry.scm"
337        "chord-generic-names.scm"
338        "molecule.scm"
339        "new-markup.scm"
340        "bass-figure.scm"
341        "music-functions.scm"
342        "define-music-properties.scm"
343        "auto-beam.scm"
344        "chord-name.scm"
345        
346        "define-translator-properties.scm"
347        "translation-functions.scm"
348        "script.scm"
349        "drums.scm"
350        "midi.scm"
351
352        "beam.scm"
353        "clef.scm"
354        "slur.scm"
355        "font.scm"
356        
357        "define-grob-properties.scm"
358        "define-grobs.scm"
359        "define-grob-interfaces.scm"
360        ))
361
362
363        
364
365
366 (set! type-p-name-alist
367   `(
368    (,boolean-or-symbol? . "boolean or symbol")
369    (,boolean? . "boolean")
370    (,char? . "char")
371    (,grob-list? . "list of grobs")
372    (,input-port? . "input port")
373    (,integer? . "integer")
374    (,list? . "list")
375    (,ly:context? . "context")
376    (,ly:dimension? . "dimension, in staff space")
377    (,ly:dir? . "direction")
378    (,ly:duration? . "duration")
379    (,ly:grob? . "grob (GRaphical OBject)")
380    (,ly:input-location? . "input location")
381    (,ly:input-location? . "input location")   
382    (,ly:moment? . "moment")
383    (,ly:music? . "music")
384    (,ly:pitch? . "pitch")
385    (,ly:translator? . "translator")
386    (,markup-list? . "list of markups")
387    (,markup? . "markup")
388    (,music-list? . "list of music")
389    (,number-or-grob? . "number or grob")
390    (,number-or-string? . "number or string")
391    (,number-pair? . "pair of numbers")
392    (,number? . "number")
393    (,output-port? . "output port")   
394    (,pair? . "pair")
395    (,procedure? . "procedure") 
396    (,scheme? . "any type")
397    (,string? . "string")
398    (,symbol? . "symbol")
399    (,vector? . "vector")
400    ))