]> git.donarmstrong.com Git - lilypond.git/blob - scm/lily.scm
df687d0f6b579bdf4fa6eb2238c3058c2741e7a7
[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--2002 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
13
14 ;;; General settings
15 ;; debugging evaluator is slower.
16
17 (debug-enable 'debug)
18 ;(debug-enable 'backtrace)
19 (read-enable 'positions)
20
21
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)
26   )
27
28 (define-public (line-location line col file)
29   "Print an input location, without column number ."
30   (string-append (number->string line) " " file)
31   )
32
33 (define-public point-and-click #f)
34
35 ;; cpp hack to get useful error message
36 (define ifdef "First run this through cpp.")
37 (define ifndef "First run this through cpp.")
38
39
40
41 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
42
43 (define-public X 0)
44 (define-public Y 1)
45 (define-public START -1)
46 (define-public STOP 1)
47 (define-public LEFT -1)
48 (define-public RIGHT 1)
49 (define-public UP 1)
50 (define-public DOWN -1)
51 (define-public CENTER 0)
52
53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
54 ;; lily specific variables.
55 (define-public default-script-alist '())
56
57 (define-public security-paranoia #f)
58
59 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
60 ;;; Unassorted utility functions.
61
62
63 ;;;;;;;;;;;;;;;;
64 ; alist
65 (define (uniqued-alist  alist acc)
66   (if (null? alist) acc
67       (if (assoc (caar alist) acc)
68           (uniqued-alist (cdr alist) acc)
69           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
70
71
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)))
76   
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)))
81
82
83 (define-public (uniqued-alist  alist acc)
84   (if (null? alist) acc
85       (if (assoc (caar alist) acc)
86           (uniqued-alist (cdr alist) acc)
87           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
88
89 (define-public (alist<? x y)
90   (string<? (symbol->string (car x))
91             (symbol->string (car y))))
92
93 ;;;;;;;;;;;;;;;;
94 ; list
95 (define (tail lst)
96   "Return tail element of LST."
97   (car (last-pair lst)))
98
99
100 (define (flatten-list lst)
101   "Unnest LST" 
102   (if (null? lst)
103       '()
104       (if (pair? (car lst))
105           (append (flatten-list (car lst)) (flatten-list  (cdr lst)))
106           (cons (car lst) (flatten-list (cdr lst))))
107   ))
108
109 (define (list-minus a b)
110   "Return list of elements in A that are not in B."
111   (if (pair? a)
112       (if (pair? b)
113           (if (member (car a) b)
114               (list-minus (cdr a) b)
115               (cons (car a) (list-minus (cdr a) b)))
116           a)
117       '()))
118
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.
122
123  TODO: rewrite using accumulator. Now it takes O(n) stack. "
124   
125   (if (null? list) '()
126       (let* ((rest (filter-list pred? (cdr list))))
127         (if (pred? (car list))
128             (cons (car list)  rest)
129             rest))))
130
131 (define-public (filter-out-list pred? list)
132   "return that part of LIST for which PRED is false."
133   (if (null? list) '()
134       (let* ((rest (filter-out-list pred? (cdr list))))
135         (if (not (pred? (car list)))
136             (cons (car list)  rest)
137             rest))))
138
139
140 (define (first-n n lst)
141   "Return first N elements of LST"
142   (if (and (pair? lst)
143            (> n 0))
144       (cons (car lst) (first-n (- n 1) (cdr lst)))
145       '()))
146
147 (define-public (uniq-list list)
148   (if (null? list) '()
149       (if (null? (cdr list))
150           list
151           (if (equal? (car list) (cadr list))
152               (uniq-list (cdr list))
153               (cons (car list) (uniq-list (cdr list)))))))
154
155 (define (butfirst-n n lst)
156   "Return all but first N entries of LST"
157   (if (pair? lst)
158       (if (> n 0)
159           (butfirst-n (- n 1) (cdr lst))
160           lst)
161       '()))
162   
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.
168
169 (split-at (lambda (x y) (= (- y x) 2))  '(1 3 5 9 11) (cons '() '()))"
170 ;; "
171
172 ;; KUT EMACS MODE.
173
174   (define (inner-split predicate l acc)
175   (cond
176    ((null? l) acc)
177    ((null? (cdr l))
178     (set-car! acc (cons (car l) (car acc)))
179     acc)
180    ((predicate (car l) (cadr l))
181     (set-car! acc (cons (car l) (car acc)))
182     (inner-split predicate (cdr l) acc))
183    (else
184     (set-car! acc (cons (car l) (car acc)))
185     (set-cdr! acc (cdr l))
186     acc)
187
188   ))
189  (let*
190     ((c (cons '() '()))
191      )
192   (inner-split predicate l  c)
193   (set-car! c (reverse! (car c))) 
194   c)
195 )
196
197
198 (define-public (split-list l sep?)
199   "
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
207 (define (split-one sep?  l acc)
208   "Split off the first parts before separator and return both parts.
209
210 "
211   ;; " KUT EMACS
212   (if (null? l)
213       (cons acc '())
214       (if (sep? (car l))
215           (cons acc (cdr l))
216           (split-one sep? (cdr l) (cons (car l) acc))
217           )
218       ))
219
220 (if (null? l)
221     '()
222     (let* ((c (split-one sep? l '())))
223       (cons (reverse! (car c) '()) (split-list (cdr c) sep?))
224       )
225     )
226 )
227
228
229 (define (other-axis a)
230   (remainder (+ a 1) 2))
231   
232
233 (define-public (widen-interval iv amount)
234    (cons (- (car iv) amount)
235          (+ (cdr iv) amount))
236 )
237
238 (define-public (write-me message x)
239   "Return X.  Display MESSAGE and write X.  Handy for debugging, possibly turned off."
240   (display message) (write x) (newline) x)
241 ;;  x)
242
243 (define (index-cell cell dir)
244   (if (equal? dir 1)
245       (cdr cell)
246       (car cell)))
247
248 (define (cons-map f x)
249   "map F to contents of X"
250   (cons (f (car x)) (f (cdr x))))
251
252 ;; used where?
253 (define-public (reduce operator list)
254   "reduce OP [A, B, C, D, ... ] =
255    A op (B op (C ... ))
256 "
257       (if (null? (cdr list)) (car list)
258           (operator (car list) (reduce operator (cdr list)))))
259
260 (define (take-from-list-until todo gathered crit?)
261   "return (G, T), where (reverse G) + T = GATHERED + TODO, and the last of G
262 is the  first to satisfy CRIT
263
264  (take-from-list-until '(1 2 3  4 5) '() (lambda (x) (eq? x 3)))
265 =>
266  ((3 2 1) 4 5)
267
268 "
269   (if (null? todo)
270       (cons gathered todo)
271       (if (crit? (car todo))
272           (cons (cons (car todo) gathered) (cdr todo))
273           (take-from-list-until (cdr todo) (cons (car todo) gathered) crit?)
274       )
275   ))
276
277 (define-public (list-insert-separator list between)
278   "Create new list, inserting BETWEEN between elements of LIST"
279   (if (null? list)
280       '()
281       (if (null? (cdr list))
282           list
283           (cons (car list)
284                 (cons between (list-insert-separator (cdr list) between)))
285   
286   )))
287
288 ;;;;;;;;;;;;;;;;
289 ; strings.
290
291 (define-public (string-join str-list sep)
292   "append the list of strings in STR-LIST, joining them with SEP"
293   (apply string-append (list-insert-separator str-list sep))
294   )
295
296 (define-public (pad-string-to str wid)
297   (string-append str (make-string (max (- wid (string-length str)) 0) #\ ))
298   )
299
300 ;;;;;;;;;;;;;;;;
301 ; other
302 (define (sign x)
303   (if (= x 0)
304       0
305       (if (< x 0) -1 1)))
306
307 (define-public (!= l r)
308   (not (= l r)))
309
310 (define-public (ly:load x)
311   (let* (
312          (fn (%search-load-path x))
313
314          )
315     (if (ly:verbose)
316         (format (current-error-port) "[~A]" fn))
317     (primitive-load fn)))
318
319
320 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
321 ;;  output
322 (use-modules (scm tex)
323              (scm ps)
324              (scm pysk)
325              (scm ascii-script)
326              (scm sketch)
327              (scm sodipodi)
328              (scm pdftex)
329              )
330
331 (define output-alist
332   `(
333     ("tex" . ("TeX output. The default output form." ,tex-output-expression))
334     ("ps" . ("Direct postscript. Requires setting GS_LIB and GS_FONTPATH" ,ps-output-expression))
335     ("scm" . ("Scheme dump: debug scheme molecule expressions" ,write))
336     ("as" . ("Asci-script. Postprocess with as2txt to get ascii art"  ,as-output-expression))
337     ("sketch" . ("Bare bones Sketch output." ,sketch-output-expression))
338     ("sodipodi" . ("Bare bones Sodipodi output." ,sodipodi-output-expression))
339     ("pdftex" . ("PDFTeX output. Was last seen nonfunctioning." ,pdftex-output-expression))
340     ))
341
342
343 (define (document-format-dumpers)
344   (map
345    (lambda (x)
346      (display (string-append  (pad-string-to 5 (car x)) (cadr x) "\n"))
347      output-alist)
348    ))
349
350 (define-public (find-dumper format )
351   (let*
352       ((d (assoc format output-alist)))
353     
354     (if (pair? d)
355         (caddr d)
356         (scm-error "Could not find dumper for format ~s" format))
357     ))
358
359 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
360 ;; other files.
361
362 (map ly:load
363                                         ; load-from-path
364      '("music-types.scm"
365        "output-lib.scm"
366        "c++.scm"
367        "chords-ignatzek.scm"
368        "chord-entry.scm"
369        "double-plus-new-chord-name.scm"
370        "molecule.scm"
371        "new-markup.scm"
372        "bass-figure.scm"
373        "music-functions.scm"
374        "music-property-description.scm"
375        "auto-beam.scm"
376        "basic-properties.scm"
377        "chord-name.scm"
378        "translator-property-description.scm"
379        "script.scm"
380        "drums.scm"
381        "midi.scm"
382
383        "beam.scm"
384        "clef.scm"
385        "slur.scm"
386        "font.scm"
387        
388        "grob-property-description.scm"
389        "grob-description.scm"
390        "context-description.scm"
391        "interface-description.scm"
392        ))
393
394
395        
396
397
398 (set! type-p-name-alist
399   `(
400    (,ly:dir? . "direction")
401    (,scheme? . "any type")
402    (,number-pair? . "pair of numbers")
403    (,ly:input-location? . "input location")   
404    (,ly:grob? . "grob (GRaphical OBject)")
405    (,grob-list? . "list of grobs")
406    (,ly:duration? . "duration")
407    (,pair? . "pair")
408    (,integer? . "integer")
409    (,list? . "list")
410    (,symbol? . "symbol")
411    (,string? . "string")
412    (,boolean? . "boolean")
413    (,ly:pitch? . "pitch")
414    (,ly:moment? . "moment")
415    (,ly:dimension? . "dimension, in staff space")
416    (,ly:input-location? . "input location")
417    (,music-list? . "list of music")
418    (,ly:music? . "music")
419    (,number? . "number")
420    (,char? . "char")
421    (,input-port? . "input port")
422    (,output-port? . "output port")   
423    (,vector? . "vector")
424    (,procedure? . "procedure") 
425    (,boolean-or-symbol? . "boolean or symbol")
426    (,number-or-string? . "number or string")
427    (,markup? . "markup")
428    (,markup-list? . "list of markups")
429    (,number-or-grob? . "number or grob")
430    ))