1 ;;;; font.scm -- construct font trees
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2004--2005 Han-Wen Nienhuys <hanwen@xs4all.nl>
9 ;; lookup-font should be written in C.
12 (define-class <Font-tree-element>
15 (define-class <Font-tree-leaf> (<Font-tree-element>)
16 (default-size #:init-keyword #:default-size)
17 (size-vector #:init-keyword #:size-vector))
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))
24 (define (make-font-tree-leaf size size-font-vector)
25 (make <Font-tree-leaf> #:default-size size #:size-vector size-font-vector))
27 (define (make-font-tree-node
29 (make <Font-tree-node>
32 #:children (make-hash-table 11)))
34 (define-method (display (leaf <Font-tree-leaf>) port)
35 (map (lambda (x) (display x port))
37 "Font-size-family: \n"
38 (slot-ref leaf 'default-size)
39 (slot-ref leaf 'size-vector))))
41 (define-method (display (node <Font-tree-node>) port)
48 "Font_node { \nqual: "
56 (display (car x) port)
58 (display (cdr x) port))
59 (hash-table->alist (font-children node)))
63 (define default-qualifier-order
64 '(font-encoding font-family font-shape font-series))
66 (define-method (add-font (node <Font-tree-node>) fprops size-family)
67 (define (assoc-delete key alist)
68 (assoc-remove! (list-copy alist) key))
69 (define (make-node fprops size-family)
71 (make-font-tree-leaf (car size-family) (cdr size-family))
72 (let* ((qual (next-qualifier default-qualifier-order fprops)))
73 (make-font-tree-node qual
74 (assoc-get qual fprops)))))
76 (define (next-qualifier order props)
78 ((and (null? props) (null? order))
80 ((null? props) (car order))
81 ((null? order) (caar props))
83 (if (assoc-get (car order) props)
85 (next-qualifier (cdr order) props)))))
87 (let* ((q (font-qualifier node))
88 (d (font-default node))
89 (v (assoc-get q fprops d))
90 (new-fprops (assoc-delete q fprops))
91 (child (hashq-ref (slot-ref node 'children)
97 (set! child (make-node new-fprops size-family))
98 (hashq-set! (slot-ref node 'children) v child)))
99 (if (pair? new-fprops)
100 (add-font child new-fprops size-family))))
103 (define-method (add-font (node <Font-tree-leaf>) fprops size-family)
104 (throw "must add to node, not leaf"))
107 (define-method (g-lookup-font (node <Font-tree-node>) alist-chain)
108 (let* ((qual (font-qualifier node))
109 (def (font-default node))
110 (val (chain-assoc-get qual alist-chain def))
111 (desired-child (hashq-ref (font-children node) val)))
114 (g-lookup-font desired-child alist-chain)
115 (g-lookup-font (hashq-ref (font-children node) def) alist-chain))))
118 (define-method (g-lookup-font (node <Font-tree-leaf>) alist-chain)
121 ;; two step call is handy for debugging.
122 (define (lookup-font node alist-chain)
123 (g-lookup-font node alist-chain))
125 ;; Each size family is a vector of fonts, loaded with a delay. The
126 ;; vector should be sorted according to ascending design size.
127 (define feta-alphabet-size-vector
128 (if (defined? 'ly:kpathsea-find-file)
129 `#(,(delay (ly:font-load "feta-alphabet11"))
130 ,(delay (ly:font-load "feta-alphabet13"))
131 ,(delay (ly:font-load "feta-alphabet14"))
132 ,(delay (ly:font-load "feta-alphabet16"))
133 ,(delay (ly:font-load "feta-alphabet18"))
134 ,(delay (ly:font-load "feta-alphabet20"))
135 ,(delay (ly:font-load "feta-alphabet23"))
136 ,(delay (ly:font-load "feta-alphabet26")))
139 (cons (ly:pt (cdr tup))
140 (format "feta-alphabet~a ~a"
152 (define-public (add-music-fonts node factor)
156 (list (cons 'font-encoding (car x)))
157 (cons (* factor (cadr x))
159 `((fetaDynamic ,(ly:pt 20.0) ,feta-alphabet-size-vector)
160 (fetaNumber ,(ly:pt 20.0) ,feta-alphabet-size-vector)
161 (fetaMusic ,(ly:pt 20.0)
162 #(,(delay (ly:font-load "emmentaler-11"))
163 ,(delay (ly:font-load "emmentaler-13"))
164 ,(delay (ly:font-load "emmentaler-14"))
165 ,(delay (ly:font-load "emmentaler-16"))
166 ,(delay (ly:font-load "emmentaler-18"))
167 ,(delay (ly:font-load "emmentaler-20"))
168 ,(delay (ly:font-load "emmentaler-23"))
169 ,(delay (ly:font-load "emmentaler-26"))))
171 (fetaBraces ,(ly:pt 20.0) #(,(delay
172 (ly:font-load "aybabtu")))))))
174 (define-public (add-cmr-fonts node factor)
175 (add-font node '((font-encoding . TeX-math))
176 `(,(* factor 10) . #(,(delay (ly:font-load "msam10")))))
179 (add-font node `((font-encoding . TeX-text)
180 (font-series . ,(vector-ref (car x) 2))
181 (font-shape . ,(vector-ref (car x) 1))
182 (font-family . ,(vector-ref (car x) 0)))
183 (cons (* factor (cadr x))
185 `((#(roman upright medium)
186 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "cmr6"))
187 ,(delay (ly:font-load "cmr8"))
188 ,(delay (ly:font-load "cmr10"))
189 ,(delay (ly:font-load "cmr17")))))
190 (#(roman upright bold)
191 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "cmbx6"))
192 ,(delay (ly:font-load "cmbx8"))
193 ,(delay (ly:font-load "cmbx10"))
194 ,(delay (ly:font-load "cmbx12")))))
195 (#(roman italic medium)
196 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "cmti7"))
197 ,(delay (ly:font-load "cmti10"))
198 ,(delay (ly:font-load "cmti12")))))
199 (#(roman italic bold)
200 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "cmbxti8"))
201 ,(delay (ly:font-load "cmbxti10"))
202 ,(delay (ly:font-load "cmbxti14")))))
203 (#(roman caps medium)
204 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "cmcsc10")))))
205 (#(roman upright bold-narrow )
206 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "cmb10")))))
207 (#(sans upright medium)
208 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "cmss8"))
209 ,(delay (ly:font-load "cmss10"))
210 ,(delay (ly:font-load "cmss12"))
211 ,(delay (ly:font-load "cmss17")))))
212 (#(typewriter upright medium)
213 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "cmtt8"))
214 ,(delay (ly:font-load "cmtt10"))
215 ,(delay (ly:font-load "cmtt12"))))))))
217 ;; Debian lmodern font support.
218 (define-public (add-cork-lm-fonts node factor)
221 (add-font node `((font-encoding . cork-lm)
222 (font-series . ,(vector-ref (car x) 2))
223 (font-shape . ,(vector-ref (car x) 1))
224 (font-family . ,(vector-ref (car x) 0)))
225 (cons (* factor (cadr x)) (cddr x))))
226 `((#(roman upright medium)
227 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "lmr6"))
228 ,(delay (ly:font-load "lmr8"))
229 ,(delay (ly:font-load "lmr10"))
230 ,(delay (ly:font-load "lmr17")))))
231 (#(roman upright bold)
232 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "lmbx6"))
233 ,(delay (ly:font-load "lmbx8"))
234 ,(delay (ly:font-load "lmbx10"))
235 ,(delay (ly:font-load "lmbx12")))))
236 (#(roman italic medium)
237 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "lmri7"))
238 ,(delay (ly:font-load "lmri10"))
239 ,(delay (ly:font-load "lmri12")))))
240 (#(roman italic bold)
241 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "lmbxi10")))))
242 (#(roman caps medium)
243 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "lmcsc10")))))
244 (#(roman upright bold-narrow )
245 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "lmb10")))))
246 (#(sans upright medium)
247 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "lmss8"))
248 ,(delay (ly:font-load "lmss10"))
249 ,(delay (ly:font-load "lmss12"))
250 ,(delay (ly:font-load "lmss17")))))
251 (#(sans upright bold)
252 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "lmssbx10")))))
254 (#(typewriter upright medium)
255 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "lmtt8"))
256 ,(delay (ly:font-load "lmtt10"))
257 ,(delay (ly:font-load "lmtt12"))))))))
259 ;; ec-fonts-mftraced font support.
260 (define-public (add-ec-fonts node factor)
262 (lambda (x) (add-font node
263 `((font-encoding . Extended-TeX-Font-Encoding---Latin)
264 (font-series . ,(vector-ref (car x) 2))
265 (font-shape . ,(vector-ref (car x) 1))
266 (font-family . ,(vector-ref (car x) 0)))
267 (cons (* factor (cadr x)) (cddr x))))
269 `((#(roman upright medium)
270 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "ecrm6"))
271 ,(delay (ly:font-load "ecrm8"))
272 ,(delay (ly:font-load "ecrm10"))
273 ,(delay (ly:font-load "ecrm17")))))
274 (#(roman upright bold)
275 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "ecbx6"))
276 ,(delay (ly:font-load "ecbx8"))
277 ,(delay (ly:font-load "ecbx10"))
278 ,(delay (ly:font-load "ecbx12")))))
279 (#(roman italic medium)
280 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "ecti7"))
281 ,(delay (ly:font-load "ecti10"))
282 ,(delay (ly:font-load "ecti12")))))
283 (#(roman italic bold)
284 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "ecbi8"))
285 ,(delay (ly:font-load "ecbi10"))
286 ,(delay (ly:font-load "ecbi14")))))
287 (#(roman caps medium)
288 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "eccc10")))))
289 (#(roman slanted-caps medium)
290 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "ecsc10")))))
291 (#(roman upright bold-narrow )
292 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "ecrb10")))))
293 (#(sans upright medium)
294 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "ecss8"))
295 ,(delay (ly:font-load "ecss10"))
296 ,(delay (ly:font-load "ecss12"))
297 ,(delay (ly:font-load "ecss17")))))
298 (#(typewriter upright medium)
299 . (,(ly:pt 10.0) . #(,(delay (ly:font-load "ectt8"))
300 ,(delay (ly:font-load "ectt10"))
301 ,(delay (ly:font-load "ectt12"))))))))
303 (define-public (add-pango-fonts node lily-family family factor)
304 (define (add-node shape series)
306 `((font-family . ,lily-family)
307 (font-shape . ,shape)
308 (font-series . ,series)
309 (font-encoding . latin1) ;; ugh.
312 `(,(ly:pt (* factor 11.0))
315 (ly:make-pango-description-string
316 `(((font-family . ,family)
317 (font-series . ,series)
318 (font-shape . ,shape)))
321 (add-node 'upright 'normal)
322 (add-node 'upright 'bold)
323 (add-node 'italic 'normal)
324 (add-node 'italic 'bold))
326 (define-public (make-cmr-tree factor)
327 (let ((n (make-font-tree-node 'font-encoding 'fetaMusic)))
328 (add-music-fonts n factor)
329 (add-cmr-fonts n factor)
330 (if (defined? 'ly:kpathsea-find-file)
332 (if (ly:kpathsea-find-file "lmr10.pfb")
333 (add-cork-lm-fonts n factor))
334 (if (ly:kpathsea-find-file "ecrm10.pfa")
335 (add-ec-fonts n factor))))
341 (define-public (make-pango-font-tree roman-str sans-str typewrite-str factor)
342 (let ((n (make-font-tree-node 'font-encoding 'fetaMusic)))
343 (add-music-fonts n factor)
344 (add-pango-fonts n 'roman roman-str factor)
345 (add-pango-fonts n 'sans sans-str factor)
346 (add-pango-fonts n 'typewriter typewrite-str factor)
350 (define-public (make-century-schoolbook-tree factor)
351 (make-pango-font-tree
352 "Century Schoolbook L"
353 "Sans" "Mono" factor))
355 (define-public (magstep x)
356 (exp (* (/ x 6) (log 2))))