1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; Copyright (C) 2004--2010 Han-Wen Nienhuys <hanwen@xs4all.nl>
5 ;;;; LilyPond is free software: you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation, either version 3 of the License, or
8 ;;;; (at your option) any later version.
10 ;;;; LilyPond is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;;;; GNU General Public License for more details.
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
20 ;; lookup-font should be written in C.
23 (define-class <Font-tree-element>
26 (define-class <Font-tree-leaf> (<Font-tree-element>)
27 (default-size #:init-keyword #:default-size)
28 (size-vector #:init-keyword #:size-vector))
30 (define-class <Font-tree-node> (<Font-tree-element>)
31 (qualifier #:init-keyword #:qualifier #:accessor font-qualifier)
32 (default #:init-keyword #:default #:accessor font-default)
33 (children #:init-keyword #:children #:accessor font-children))
35 (define (make-font-tree-leaf size size-font-vector)
36 (make <Font-tree-leaf> #:default-size size #:size-vector size-font-vector))
38 (define (make-font-tree-node
40 (make <Font-tree-node>
43 #:children (make-hash-table 11)))
45 (define-method (display (leaf <Font-tree-leaf>) port)
46 (map (lambda (x) (display x port))
48 "#<Font-size-family:\n"
49 (slot-ref leaf 'default-size)
50 (slot-ref leaf 'size-vector)
54 (define-method (display (node <Font-tree-node>) port)
67 (display (car x) port)
69 (display (cdr x) port))
70 (hash-table->alist (font-children node)))
73 (define default-qualifier-order
74 '(font-encoding font-family font-shape font-series))
76 (define-method (add-font (node <Font-tree-node>) fprops size-family)
77 (define (assoc-delete key alist)
78 (assoc-remove! (list-copy alist) key))
80 (define (make-node fprops size-family)
82 (make-font-tree-leaf (car size-family) (cdr size-family))
83 (let* ((qual (next-qualifier default-qualifier-order fprops)))
84 (make-font-tree-node qual
85 (assoc-get qual fprops)))))
87 (define (next-qualifier order props)
89 ((and (null? props) (null? order))
91 ((null? props) (car order))
92 ((null? order) (caar props))
94 (if (assoc-get (car order) props)
96 (next-qualifier (cdr order) props)))))
98 (let* ((q (font-qualifier node))
99 (d (font-default node))
100 (v (assoc-get q fprops d))
101 (new-fprops (assoc-delete q fprops))
102 (child (hashq-ref (slot-ref node 'children)
106 (set! child (make-node new-fprops size-family))
107 (hashq-set! (slot-ref node 'children) v child)))
108 (if (pair? new-fprops)
109 (add-font child new-fprops size-family))))
111 (define-method (add-font (node <Font-tree-leaf>) fprops size-family)
112 (throw "must add to node, not leaf"))
114 (define-method (g-lookup-font (node <Font-tree-node>) alist-chain)
115 (let* ((qual (font-qualifier node))
116 (def (font-default node))
117 (val (chain-assoc-get qual alist-chain def))
118 (desired-child (hashq-ref (font-children node) val)))
121 (g-lookup-font desired-child alist-chain)
122 (g-lookup-font (hashq-ref (font-children node) def) alist-chain))))
124 (define-method (g-lookup-font (node <Font-tree-leaf>) alist-chain)
127 ;; two step call is handy for debugging.
128 (define (lookup-font node alist-chain)
129 (g-lookup-font node alist-chain))
132 ;; Ugh. Currently, we load the PFB Feta fonts for `fetaDynamic' with
133 ;; Pango. This should be changed to load the Emmentaler fonts instead
134 ;; (with Pango too), but then we need support for a `font-style'
135 ;; property which isn't implemented yet.
136 (define feta-alphabet-size-vector
139 (cons (ly:pt (cdr tup))
140 (format "feta-alphabet~a ~a"
152 ;; Each size family is a vector of fonts, loaded with a delay. The
153 ;; vector should be sorted according to ascending design size.
154 (define-public (add-music-fonts node name family design-size-list factor)
158 NODE the font tree to modify.
159 NAME is the basename for the music font. NAME-DESIGNSIZE.otf should be the music font,
160 NAME-brace.otf should have piano braces.
161 DESIGN-SIZE-LIST is a list of numbers, used as suffix for font filenames
162 FACTOR is size factor relative to default size that is being used. This is used
163 to select the proper design size for text fonts.
168 (list (cons 'font-encoding (car x))
169 (cons 'font-family family))
170 (cons (* factor (cadr x))
172 `((fetaDynamic ,(ly:pt 20.0) ,feta-alphabet-size-vector)
173 (fetaNumber ,(ly:pt 20.0) ,feta-alphabet-size-vector)
174 (fetaMusic ,(ly:pt 20.0)
177 (delay (ly:system-font-load (format "~a-~a" name size))))
180 (fetaBraces ,(ly:pt 20.0)
181 #(,(delay (ly:system-font-load
182 (format "~a-brace" name)))))
185 (define-public (add-pango-fonts node lily-family family factor)
186 ;; Synchronized with the `text-font-size' variable in
187 ;; layout-set-absolute-staff-size-in-module (see paper.scm).
188 (define text-font-size (ly:pt (* factor 11.0)))
190 (define (add-node shape series)
192 `((font-family . ,lily-family)
193 (font-shape . ,shape)
194 (font-series . ,series)
195 (font-encoding . latin1) ;; ugh.
200 (ly:make-pango-description-string
201 `(((font-family . ,family)
202 (font-series . ,series)
203 (font-shape . ,shape)))
206 (add-node 'upright 'normal)
207 (add-node 'caps 'normal)
208 (add-node 'upright 'bold)
209 (add-node 'italic 'normal)
210 (add-node 'italic 'bold))
212 (define-public (make-pango-font-tree roman-str sans-str typewrite-str factor)
213 (let ((n (make-font-tree-node 'font-encoding 'fetaMusic)))
214 (add-music-fonts n "emmentaler" 'feta '(11 13 14 16 18 20 23 26) factor)
215 (add-pango-fonts n 'roman roman-str factor)
216 (add-pango-fonts n 'sans sans-str factor)
217 (add-pango-fonts n 'typewriter typewrite-str factor)
220 (define-public (make-century-schoolbook-tree factor)
221 (make-pango-font-tree
222 "Century Schoolbook L,serif"
223 "sans-serif" "monospace" factor))
225 (define-public all-text-font-encodings
228 (define-public all-music-font-encodings
234 (define-public (magstep s)
235 (exp (* (/ s 6) (log 2))))
237 (define-public (magnification->font-size m)
238 (* 6 (/ (log m) (log 2))))