]> git.donarmstrong.com Git - lilypond.git/blob - scm/font.scm
Update from Trevor.
[lilypond.git] / scm / font.scm
1 ;;;; font.scm -- construct font trees
2 ;;;;
3 ;;;;  source file of the GNU LilyPond music typesetter
4 ;;;; 
5 ;;;; (c) 2004--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
6
7 ;; TODO:
8 ;;
9 ;; lookup-font should be written in  C.
10 ;;
11
12 (define-class <Font-tree-element>
13   ())
14
15 (define-class <Font-tree-leaf> (<Font-tree-element>)
16   (default-size #:init-keyword #:default-size)
17   (size-vector  #:init-keyword #:size-vector))
18
19 (define-class <Font-tree-node> (<Font-tree-element>)
20   (qualifier #:init-keyword #:qualifier  #:accessor font-qualifier)
21   (default #:init-keyword #:default #:accessor font-default)
22   (children #:init-keyword #:children #:accessor font-children))
23
24 (define (make-font-tree-leaf size size-font-vector)
25   (make <Font-tree-leaf> #:default-size size #:size-vector size-font-vector))
26
27 (define (make-font-tree-node
28          qualifier default)
29   (make <Font-tree-node>
30     #:qualifier qualifier
31     #:default default 
32     #:children (make-hash-table 11)))
33
34 (define-method (display (leaf <Font-tree-leaf>) port)
35   (map (lambda (x) (display x port))
36        (list
37         "#<Font-size-family: \n"
38         (slot-ref leaf 'default-size) 
39         (slot-ref leaf 'size-vector)
40         "#>"
41         )))
42
43 (define-method (display (node <Font-tree-node>) port)
44
45   (map
46    (lambda (x)
47      (display x port))
48
49    (list
50     "Font_node { \nqual: "
51     (font-qualifier node)
52     "(def: "
53     (font-default node)
54     ") {\n"))
55   (for-each 
56    (lambda (x)
57      (display "\n")
58      (display (car x) port)
59      (display "=" port)
60      (display (cdr x) port))
61    (hash-table->alist (font-children node)))
62   (display "} } \n"))
63
64
65 (define default-qualifier-order
66   '(font-encoding font-family font-shape font-series))
67
68 (define-method (add-font (node <Font-tree-node>) fprops size-family)
69   (define (assoc-delete key alist)
70     (assoc-remove! (list-copy alist) key))
71   
72   (define (make-node fprops size-family)
73     (if (null? fprops)
74         (make-font-tree-leaf (car size-family) (cdr size-family))
75         (let* ((qual (next-qualifier default-qualifier-order fprops)))
76           (make-font-tree-node qual
77                                (assoc-get qual fprops)))))
78
79   (define (next-qualifier order props)
80     (cond
81      ((and (null? props) (null? order))
82       #f)
83      ((null? props) (car order))
84      ((null? order) (caar props))
85      (else
86       (if (assoc-get (car order) props)
87           (car order)
88           (next-qualifier (cdr order) props)))))
89
90   (let* ((q (font-qualifier node))
91          (d (font-default node))
92          (v (assoc-get q fprops d))
93          (new-fprops (assoc-delete q fprops))
94          (child (hashq-ref (slot-ref node 'children)
95                            v #f)))
96
97
98     (if (not child)
99         (begin
100           (set! child (make-node new-fprops size-family))
101           (hashq-set! (slot-ref node 'children) v child)))
102     (if (pair? new-fprops)
103         (add-font child new-fprops size-family))))
104
105
106 (define-method (add-font (node <Font-tree-leaf>) fprops size-family)
107   (throw "must add to node, not leaf"))
108
109
110 (define-method (g-lookup-font (node <Font-tree-node>) alist-chain)
111   (let* ((qual (font-qualifier node))
112          (def (font-default node))
113          (val (chain-assoc-get qual alist-chain def))
114          (desired-child (hashq-ref (font-children node) val)))
115
116     (if desired-child
117         (g-lookup-font desired-child alist-chain)
118         (g-lookup-font (hashq-ref (font-children node) def) alist-chain))))
119
120
121 (define-method (g-lookup-font (node <Font-tree-leaf>) alist-chain)
122   node)
123
124 ;; two step call  is handy for debugging.
125 (define (lookup-font node alist-chain)
126   (g-lookup-font node alist-chain))
127
128 ;; Each size family is a vector of fonts, loaded with a delay.  The
129 ;; vector should be sorted according to ascending design size.
130 (define feta-alphabet-size-vector
131   (if (defined? 'ly:kpathsea-find-file)
132       `#(,(delay  (ly:font-load "feta-alphabet11"))
133          ,(delay  (ly:font-load "feta-alphabet13"))
134          ,(delay  (ly:font-load "feta-alphabet14"))
135          ,(delay  (ly:font-load "feta-alphabet16"))
136          ,(delay  (ly:font-load "feta-alphabet18"))
137          ,(delay  (ly:font-load "feta-alphabet20"))
138          ,(delay  (ly:font-load "feta-alphabet23"))
139          ,(delay  (ly:font-load "feta-alphabet26")))
140       (list->vector
141        (map (lambda (tup)
142               (cons (ly:pt (cdr tup))
143                     (format "feta-alphabet~a ~a"
144                             (car tup)
145                             (ly:pt (cdr tup)))))
146             '((11 . 11.22)
147               (13 . 12.60)
148               (14 .  14.14)
149               (16 . 15.87)
150               (18 . 17.82)
151               (20 . 20)
152               (23 . 22.45)
153               (26 . 25.20))))))
154
155 (define-public (add-music-fonts node factor)
156   (for-each
157    (lambda (x)
158      (add-font node
159                (list (cons 'font-encoding (car x)))
160                (cons (* factor (cadr x))
161                      (caddr x))))
162    `((fetaDynamic ,(ly:pt 20.0)  ,feta-alphabet-size-vector)
163      (fetaNumber ,(ly:pt 20.0)  ,feta-alphabet-size-vector)
164      (fetaMusic ,(ly:pt 20.0)
165                 #(,(delay  (ly:font-load "emmentaler-11"))
166                   ,(delay  (ly:font-load "emmentaler-13"))                
167                   ,(delay  (ly:font-load "emmentaler-14"))
168                   ,(delay  (ly:font-load "emmentaler-16"))                
169                   ,(delay  (ly:font-load "emmentaler-18"))
170                   ,(delay  (ly:font-load "emmentaler-20"))                
171                   ,(delay  (ly:font-load "emmentaler-23"))                
172                   ,(delay  (ly:font-load "emmentaler-26"))))
173
174      (fetaBraces ,(ly:pt 20.0) #(,(delay
175                             (ly:font-load "aybabtu")))))))
176
177 (define-public (add-cmr-fonts node factor)
178   (add-font node '((font-encoding . TeX-math))
179             `(,(* factor 10) . #(,(delay (ly:font-load "msam10")))))
180   (for-each
181    (lambda (x)
182      (add-font node `((font-encoding . TeX-text)
183                       (font-series . ,(vector-ref (car x) 2))
184                       (font-shape . ,(vector-ref (car x) 1))
185                       (font-family . ,(vector-ref (car x) 0)))
186                (cons (* factor (cadr x))
187                      (cddr x))))
188    `((#(roman upright medium) 
189       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "cmr6"))
190                   ,(delay (ly:font-load "cmr8")) 
191                   ,(delay (ly:font-load "cmr10"))
192                   ,(delay (ly:font-load "cmr17")))))
193      (#(roman upright bold) 
194       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "cmbx6"))
195                   ,(delay (ly:font-load "cmbx8"))
196                   ,(delay (ly:font-load "cmbx10"))
197                   ,(delay (ly:font-load "cmbx12")))))
198      (#(roman italic medium) 
199       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "cmti7"))
200                   ,(delay (ly:font-load "cmti10"))
201                   ,(delay (ly:font-load "cmti12")))))
202      (#(roman italic bold) 
203       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "cmbxti8"))
204                   ,(delay (ly:font-load "cmbxti10"))
205                   ,(delay (ly:font-load "cmbxti14")))))
206      (#(roman caps medium) 
207       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "cmcsc10")))))
208      (#(roman upright bold-narrow ) 
209       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "cmb10")))))
210      (#(sans upright medium) 
211       . (,(ly:pt 10.0)  . #(,(delay (ly:font-load "cmss8"))
212                    ,(delay (ly:font-load "cmss10"))
213                    ,(delay (ly:font-load "cmss12"))
214                    ,(delay (ly:font-load "cmss17")))))
215      (#(typewriter upright medium) 
216       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "cmtt8"))
217                   ,(delay (ly:font-load "cmtt10"))
218                   ,(delay (ly:font-load "cmtt12"))))))))
219
220 ;; Debian lmodern font support.
221 (define-public (add-cork-lm-fonts node factor)
222   (for-each
223    (lambda (x)
224      (add-font node `((font-encoding . cork-lm)
225                       (font-series . ,(vector-ref (car x) 2))
226                       (font-shape . ,(vector-ref (car x) 1))
227                       (font-family . ,(vector-ref (car x) 0)))
228                (cons (* factor (cadr x)) (cddr x))))
229    `((#(roman upright medium) 
230       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "lmr6"))
231                   ,(delay (ly:font-load "lmr8"))
232                   ,(delay (ly:font-load "lmr10"))
233                   ,(delay (ly:font-load "lmr17")))))
234      (#(roman upright bold) 
235       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "lmbx6"))
236                   ,(delay (ly:font-load "lmbx8"))
237                   ,(delay (ly:font-load "lmbx10"))
238                   ,(delay (ly:font-load "lmbx12")))))
239      (#(roman italic medium) 
240       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "lmri7"))
241                   ,(delay (ly:font-load "lmri10"))
242                   ,(delay (ly:font-load "lmri12")))))
243      (#(roman italic bold)
244       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "lmbxi10")))))
245      (#(roman caps medium)
246       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "lmcsc10")))))
247      (#(roman upright bold-narrow ) 
248       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "lmb10")))))
249      (#(sans upright medium) 
250       . (,(ly:pt 10.0)  . #(,(delay (ly:font-load "lmss8"))
251                    ,(delay (ly:font-load "lmss10"))
252                    ,(delay (ly:font-load "lmss12"))
253                    ,(delay (ly:font-load "lmss17")))))
254      (#(sans upright bold) 
255       . (,(ly:pt 10.0)  . #(,(delay (ly:font-load "lmssbx10")))))
256
257      (#(typewriter upright medium) 
258       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "lmtt8"))
259                   ,(delay (ly:font-load "lmtt10"))
260                   ,(delay (ly:font-load "lmtt12"))))))))
261
262 ;; ec-fonts-mftraced font support.
263 (define-public (add-ec-fonts node factor)
264   (for-each
265    (lambda (x) (add-font node
266                          `((font-encoding . Extended-TeX-Font-Encoding---Latin)
267                            (font-series . ,(vector-ref (car x) 2))
268                            (font-shape . ,(vector-ref (car x) 1))
269                            (font-family . ,(vector-ref (car x) 0)))
270                          (cons (* factor (cadr x)) (cddr x))))
271
272    `((#(roman upright medium) 
273       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "ecrm6"))
274                   ,(delay (ly:font-load "ecrm8"))
275                   ,(delay (ly:font-load "ecrm10"))
276                   ,(delay (ly:font-load "ecrm17")))))
277      (#(roman upright bold) 
278       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "ecbx6"))
279                   ,(delay (ly:font-load "ecbx8"))
280                   ,(delay (ly:font-load "ecbx10"))
281                   ,(delay (ly:font-load "ecbx12")))))
282      (#(roman italic medium) 
283       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "ecti7"))
284                   ,(delay (ly:font-load "ecti10"))
285                   ,(delay (ly:font-load "ecti12")))))
286      (#(roman italic bold) 
287       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "ecbi8"))
288                   ,(delay (ly:font-load "ecbi10"))
289                   ,(delay (ly:font-load "ecbi14")))))
290      (#(roman caps medium) 
291       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "eccc10")))))
292      (#(roman slanted-caps medium) 
293       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "ecsc10")))))
294      (#(roman upright bold-narrow ) 
295       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "ecrb10")))))
296      (#(sans upright medium) 
297       . (,(ly:pt 10.0)  . #(,(delay (ly:font-load "ecss8"))
298                    ,(delay (ly:font-load "ecss10"))
299                    ,(delay (ly:font-load "ecss12"))
300                    ,(delay (ly:font-load "ecss17")))))
301      (#(typewriter upright medium) 
302       . (,(ly:pt 10.0) . #(,(delay (ly:font-load "ectt8"))
303                   ,(delay (ly:font-load "ectt10"))
304                   ,(delay (ly:font-load "ectt12"))))))))
305
306 (define-public (add-pango-fonts node lily-family family factor)
307   (define (add-node shape series)
308     (add-font node
309               `((font-family . ,lily-family)
310                 (font-shape . ,shape)
311                 (font-series . ,series)
312                 (font-encoding . latin1) ;; ugh.
313                 )
314               
315               `(,(ly:pt (* factor 11.0))
316                 . #(,(cons
317                      (ly:pt 12)
318                      (ly:make-pango-description-string
319                        `(((font-family . ,family)
320                           (font-series . ,series)
321                           (font-shape . ,shape)))
322                        (ly:pt 12)))))))
323
324   (add-node 'upright 'normal) 
325   (add-node 'caps 'normal) 
326   (add-node 'upright 'bold) 
327   (add-node 'italic 'normal)
328   (add-node 'italic 'bold))
329
330 (define-public (make-cmr-tree factor)
331   (let*
332       ((n (make-font-tree-node 'font-encoding 'fetaMusic))
333        (module (resolve-module '(scm kpathsea)))
334        (find (eval 'ly:kpathsea-find-file module))
335        )
336     (add-music-fonts n factor)
337     (add-cmr-fonts n factor)
338     
339     (if (find "lmr10.pfb")
340         (add-cork-lm-fonts n factor))
341     (if (find "ecrm10.pfa")
342         (add-ec-fonts n factor))
343     n))
344
345
346
347
348 (define-public (make-pango-font-tree roman-str sans-str typewrite-str factor)
349   (let ((n (make-font-tree-node 'font-encoding 'fetaMusic)))
350     (add-music-fonts n factor)
351     (add-pango-fonts n 'roman roman-str factor)
352     (add-pango-fonts n 'sans sans-str factor)
353     (add-pango-fonts n 'typewriter typewrite-str factor)
354     n))
355
356
357 (define-public (make-century-schoolbook-tree factor)
358   (make-pango-font-tree
359     "Century Schoolbook L" 
360     "Sans" "Mono" factor))
361
362 (define-public (magstep s)
363   (exp (* (/ s 6) (log 2))))
364
365 (define-public (magnification->font-size m)
366   (* 6 (/ (log m) (log 2))))