]> git.donarmstrong.com Git - lilypond.git/blob - scm/font.scm
Release: bump Welcome versions.
[lilypond.git] / scm / font.scm
1 ;;;; This file is part of LilyPond, the GNU music typesetter.
2 ;;;;
3 ;;;; Copyright (C) 2004--2015 Han-Wen Nienhuys <hanwen@xs4all.nl>
4 ;;;;
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.
9 ;;;;
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.
14 ;;;;
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/>.
17
18 ;; TODO:
19 ;;
20 ;; lookup-font should be written in  C.
21 ;;
22
23 ;; We have a tree, where each level of the tree is a qualifier
24 ;; (eg. encoding, family, shape, series etc.)  this defines the levels
25 ;; in the tree.  The first one is encoding, so we can directly select
26 ;; between text or music in the first step of the selection.
27 (define default-qualifier-order
28   '(font-encoding font-family font-shape font-series))
29
30 (define-class <Font-tree-element>
31   ())
32
33 (define-class <Font-tree-leaf> (<Font-tree-element>)
34   (default-size #:init-keyword #:default-size)
35   (size-vector  #:init-keyword #:size-vector))
36
37 (define-class <Font-tree-node> (<Font-tree-element>)
38   (qualifier #:init-keyword #:qualifier  #:accessor font-qualifier)
39   (default #:init-keyword #:default #:accessor font-default)
40   (children #:init-keyword #:children #:accessor font-children))
41
42 (define (make-font-tree-leaf size size-font-vector)
43   (make <Font-tree-leaf> #:default-size size #:size-vector size-font-vector))
44
45 (define (make-font-tree-node
46          qualifier default)
47   (make <Font-tree-node>
48     #:qualifier qualifier
49     #:default default
50     #:children (make-hash-table 11)))
51
52 (define-method (display (leaf <Font-tree-leaf>) port)
53   (for-each (lambda (x) (display x port))
54             (list
55              "#<Font-size-family:\n"
56              (slot-ref leaf 'default-size)
57              (slot-ref leaf 'size-vector)
58              "#>"
59              )))
60
61 (define-method (display (node <Font-tree-node>) port)
62   (for-each
63    (lambda (x)
64      (display x port))
65    (list
66     "Font_node {\nqual: "
67     (font-qualifier node)
68     "(def: "
69     (font-default node)
70     ") {\n"))
71   (for-each
72    (lambda (x)
73      (display "\n")
74      (display (car x) port)
75      (display "=" port)
76      (display (cdr x) port))
77    (hash-table->alist (font-children node)))
78   (display "} }\n"))
79
80
81 (define-method (add-font (node <Font-tree-node>) fprops size-family)
82   (define (assoc-delete key alist)
83     (assoc-remove! (list-copy alist) key))
84
85   (define (make-node fprops size-family)
86     (if (null? fprops)
87         (make-font-tree-leaf (car size-family) (cdr size-family))
88         (let* ((qual (next-qualifier default-qualifier-order fprops)))
89           (make-font-tree-node qual
90                                (assoc-get qual fprops)))))
91
92   (define (next-qualifier order props)
93     (cond
94      ((and (null? props) (null? order))
95       #f)
96      ((null? props) (car order))
97      ((null? order) (caar props))
98      (else
99       (if (assoc-get (car order) props)
100           (car order)
101           (next-qualifier (cdr order) props)))))
102
103   (let* ((q (font-qualifier node))
104          (d (font-default node))
105          (v (assoc-get q fprops d))
106          (new-fprops (assoc-delete q fprops))
107          (child (hashq-ref (slot-ref node 'children)
108                            v #f)))
109     (if (not child)
110         (begin
111           (set! child (make-node new-fprops size-family))
112           (hashq-set! (slot-ref node 'children) v child)))
113     (if (pair? new-fprops)
114         (add-font child new-fprops size-family))))
115
116 (define-method (add-font (node <Font-tree-leaf>) fprops size-family)
117   (throw "must add to node, not leaf"))
118
119 (define-method (g-lookup-font (node <Font-tree-node>) alist-chain)
120   (let* ((qual (font-qualifier node))
121          (def (font-default node))
122          (val (chain-assoc-get qual alist-chain def))
123          (desired-child (hashq-ref (font-children node) val)))
124
125     (if desired-child
126         (g-lookup-font desired-child alist-chain)
127         (g-lookup-font (hashq-ref (font-children node) def) alist-chain))))
128
129 (define-method (g-lookup-font (node <Font-tree-leaf>) alist-chain)
130   node)
131
132 ;; two step call is handy for debugging.
133 (define (lookup-font node alist-chain)
134   (g-lookup-font node alist-chain))
135
136 ;; TODO - we could actually construct this by loading all OTFs and
137 ;; inspecting their design size fields.
138 (define-public feta-design-size-mapping
139   '((11 . 11.22)
140     (13 . 12.60)
141     (14 . 14.14)
142     (16 . 15.87)
143     (18 . 17.82)
144     (20 . 20)
145     (23 . 22.45)
146     (26 . 25.20)))
147
148 ;; Each size family is a vector of fonts, loaded with a delay.  The
149 ;; vector should be sorted according to ascending design size.
150 (define-public (add-music-fonts node family name brace design-size-alist factor)
151   "Set up music fonts.
152
153 Arguments:
154 @itemize
155 @item
156 @var{node} is the font tree to modify.
157
158 @item
159 @var{family} is the family name of the music font.
160
161 @item
162 @var{name} is the basename for the music font.
163 @file{@var{name}-<designsize>.otf} should be the music font,
164
165 @item
166 @var{brace} is the basename for the brace font.
167 @file{@var{brace}-brace.otf} should have piano braces.
168
169 @item
170 @var{design-size-alist} is a list of @code{(rounded . designsize)}.
171 @code{rounded} is a suffix for font filenames, while @code{designsize}
172 should be the actual design size.  The latter is used for text fonts
173 loaded through pango/@/fontconfig.
174
175 @item
176 @var{factor} is a size factor relative to the default size that is being
177 used.  This is used to select the proper design size for the text fonts.
178 @end itemize"
179   (for-each
180    (lambda (x)
181      (add-font node
182                (list (cons 'font-encoding (car x))
183                      (cons 'font-family family))
184                (cons (* factor (cadr x))
185                      (caddr x))))
186
187    `((fetaText ,(ly:pt 20.0)
188                ,(list->vector
189                  (map (lambda (tup)
190                         (cons (ly:pt (cdr tup))
191                               (format #f "~a-~a ~a"
192                                       name
193                                       (car tup)
194                                       (ly:pt (cdr tup)))))
195                       design-size-alist)))
196      (fetaMusic ,(ly:pt 20.0)
197                 ,(list->vector
198                   (map (lambda (size-tup)
199                          (delay (ly:system-font-load
200                                  (format #f "~a-~a" name (car size-tup)))))
201                        design-size-alist
202                        )))
203      (fetaBraces ,(ly:pt 20.0)
204                  #(,(delay (ly:system-font-load
205                             (format #f "~a-brace" brace)))))
206      )))
207
208 (define-public (add-pango-fonts node lily-family family factor)
209   ;; Synchronized with the `text-font-size' variable in
210   ;; layout-set-absolute-staff-size-in-module (see paper.scm).
211   (define text-font-size (ly:pt (* factor 11.0)))
212
213   (define (add-node shape series)
214     (add-font node
215               `((font-family . ,lily-family)
216                 (font-shape . ,shape)
217                 (font-series . ,series)
218                 (font-encoding . latin1) ;; ugh.
219                 )
220               `(,text-font-size
221                 . #(,(cons
222                       (ly:pt 12)
223                       (ly:make-pango-description-string
224                        `(((font-family . ,family)
225                           (font-series . ,series)
226                           (font-shape . ,shape)))
227                        (ly:pt 12)))))))
228
229   (add-node 'upright 'normal)
230   (add-node 'caps 'normal)
231   (add-node 'upright 'bold)
232   (add-node 'italic 'normal)
233   (add-node 'italic 'bold))
234
235 ; This function allows the user to change the specific fonts, leaving others
236 ; to the default values. This way, "make-pango-font-tree"'s syntax doesn't
237 ; have to change from the user's perspective.
238 ;
239 ; Usage:
240 ;   \paper {
241 ;     #(define fonts
242 ;       (set-global-fonts
243 ;        #:music "gonville"  ; (the main notation font)
244 ;        #:roman "FreeSerif" ; (the main/serif text font)
245 ;       ))
246 ;   }
247 ;
248 ; Leaving out "#:brace", "#:sans", and "#:typewriter" leave them at 
249 ; "emmentaler", "sans-serif", and "monospace", respectively. All fonts are
250 ; still accesible through the usual scheme symbols: 'feta, 'roman, 'sans, and
251 ; 'typewriter.
252 ;
253 ; Note that 'LilyPond Serif', 'LilyPond Sans Serif' and 'Lilypond Monospace'
254 ; are aliases that are defined in mf/00-lilypond-fonts.conf.in (source file)
255 ; or fonts/00-lilypond-fonts.conf (installed file).
256
257 (define*-public (set-global-fonts #:key
258   (music "emmentaler")
259   (brace "emmentaler")
260   (roman (if (eq? (ly:get-option 'backend) 'svg)
261              "serif" "LilyPond Serif"))
262   (sans (if (eq? (ly:get-option 'backend) 'svg)
263             "sans-serif" "LilyPond Sans Serif"))
264   (typewriter (if (eq? (ly:get-option 'backend) 'svg)
265                   "monospace" "LilyPond Monospace"))
266   (factor 1))
267   (let ((n (make-font-tree-node 'font-encoding 'fetaMusic)))
268     (add-music-fonts n 'feta music brace feta-design-size-mapping factor)
269     (add-pango-fonts n 'roman roman factor)
270     (add-pango-fonts n 'sans sans factor)
271     (add-pango-fonts n 'typewriter typewriter factor)
272     n))
273
274 (define-public (make-pango-font-tree roman-str sans-str typewrite-str factor)
275   (let ((n (make-font-tree-node 'font-encoding 'fetaMusic)))
276     (add-music-fonts n 'feta "emmentaler" "emmentaler" feta-design-size-mapping factor)
277     (add-pango-fonts n 'roman roman-str factor)
278     (add-pango-fonts n 'sans sans-str factor)
279     (add-pango-fonts n 'typewriter typewrite-str factor)
280     n))
281
282 (define-public (make-default-fonts-tree factor)
283   (make-pango-font-tree
284    (if (eq? (ly:get-option 'backend) 'svg) "serif" "LilyPond Serif")
285    (if (eq? (ly:get-option 'backend) 'svg) "sans-serif" "LilyPond Sans Serif")
286    (if (eq? (ly:get-option 'backend) 'svg) "monospace" "LilyPond Monospace")
287    factor))
288
289 (define-public all-text-font-encodings
290   '(latin1))
291
292 (define-public all-music-font-encodings
293   '(fetaBraces
294     fetaMusic
295     fetaText))
296
297 (define-public (magstep s)
298   (exp (* (/ s 6) (log 2))))
299
300 (define-public (magnification->font-size m)
301   (* 6 (/ (log m) (log 2))))