2 ;;; font.scm -- implement Font stuff
4 ;;; source file of the GNU LilyPond music typesetter
6 ;;; (c) 2000 Jan Nieuwenhuizen <janneke@gnu.org>
10 ;; Corresponding properties:
12 ;; font-series font-shape font-family font-name font-point font-size
15 (define style-to-font-alist
17 (finger . "* * number * * -3")
18 (volta . "* * number * * -2")
19 (timesig . "* * number * * 0")
20 (mmrest . "* * number * * 0")
21 (mark . "* * number * * 1")
22 (script . "* * roman * * -1")
23 (large . "* * roman * * 1")
24 (Large . "bold * roman * * 2")
25 (dynamic . "bold * dynamic * * 0")
28 (define paper20-style-sheet-alist-template
30 (("medium upright music feta 20" . 0) . "feta20")
31 (("medium upright music feta 16" . -1) . "feta16")
32 (("medium upright music feta 13" . -2) . "feta13")
33 (("medium upright music feta 13" . -3) . "feta11")
34 (("medium upright music feta 13" . -4) . "feta11")
35 (("medium upright music feta 23" . 1) . "feta23")
36 (("medium upright music feta 26" . 2) . "feta26")
37 (("medium upright braces feta-braces 20" . 0) . "feta-braces20")
38 (("bold italic dynamic feta-din 14" . 2) . "feta-din14")
39 (("bold italic dynamic feta-din 13" . 1) . "feta-din13")
40 (("bold italic dynamic feta-din 12" . 0) . "feta-din12")
41 (("bold italic dynamic feta-din 10" . -1) . "feta-din10")
42 (("bold italic dynamic feta-din 8" . -2) . "feta-din8")
43 (("bold italic dynamic feta-din 7" . -3) . "feta-din7")
44 (("bold italic dynamic feta-din 6" . -4) . "feta-din6")
45 (("bold italic dynamic feta-din 5" . -5) . "feta-din5")
46 (("bold italic dynamic feta-din 4" . -6) . "feta-din4")
48 (("medium upright number feta-nummer 13" . 3) . "feta-nummer14")
49 (("medium upright number feta-nummer 13" . 2) . "feta-nummer13")
50 (("medium upright number feta-nummer 12" . 1) . "feta-nummer12")
51 (("medium upright number feta-nummer 10" . 0) . "feta-nummer10")
52 (("medium upright number feta-nummer 8" . -1) . "feta-nummer8")
53 (("medium upright number feta-nummer 7" . -2) . "feta-nummer7")
54 (("medium upright number feta-nummer 6" . -3) . "feta-nummer6")
55 (("medium upright number feta-nummer 5" . -4) . "feta-nummer5")
56 (("medium upright number feta-nummer 4" . -5) . "feta-nummer4")
57 (("medium upright roman cmr 8" . -3) . "cmr8" )
58 (("medium upright roman cmr 8" . -2) . "cmr8" )
59 (("medium upright roman cmr 8" . -1) . "cmr8" )
60 (("medium upright roman cmr 10" . 0) . "cmr10")
61 (("medium upright roman cmr 12" . 1) . "cmr12")
62 (("bold upright roman cmbx 10" . 0) . "cmbx10")
63 (("bold upright roman cmbx 12" . 1) . "cmbx12")
64 (("medium italic roman cmbx 10" . 0) . "cmbx10")
65 (("medium italic roman cmbx 12" . 1) . "cmbx12")
66 (("medium upright math msam 10" . -3) . "msam10")
67 (("medium upright math msam 10" . -2) . "msam10")
68 (("medium upright math msam 10" . -1) . "msam10")
69 (("medium upright math msam 10" . 0) . "msam10")
72 (define (style-sheet-template-entry-compile entry size)
74 (string-append (caar entry)
76 (number->string (- (cdar entry) size))
80 (define style-sheet-alist
82 (paper11 . ,(map (lambda (x) (style-sheet-template-entry-compile x -3))
83 paper20-style-sheet-alist-template))
84 (paper13 . ,(map (lambda (x) (style-sheet-template-entry-compile x -2))
85 paper20-style-sheet-alist-template))
86 (paper16 . ,(map (lambda (x) (style-sheet-template-entry-compile x -1))
87 paper20-style-sheet-alist-template))
88 (paper20 . ,(map (lambda (x) (style-sheet-template-entry-compile x 0))
89 paper20-style-sheet-alist-template))
90 (paper23 . ,(map (lambda (x) (style-sheet-template-entry-compile x 1))
91 paper20-style-sheet-alist-template))
92 (paper26 . ,(map (lambda (x) (style-sheet-template-entry-compile x 2))
93 paper20-style-sheet-alist-template))
96 (define (font-regexp-to-font-name paper regexp)
97 (let ((style-sheet (cdr (assoc paper style-sheet-alist))))
98 (let loop ((fonts style-sheet))
99 (if (string-match regexp (caar fonts))
101 (if (pair? (cdr fonts))
105 (define (properties-to-font-name paper properties-alist)
106 (let ((font-regexp (apply string-append
109 (let ((entry (assoc key properties-alist)))
110 (if entry (cdr entry) "[^ ]+"))
112 '(font-series font-shape font-family font-name font-point font-size)))))
113 ;;(display "font-regexp: `")
114 ;;(display font-regexp)
116 (font-regexp-to-font-name paper font-regexp)))
118 (define markup-abbrev-to-properties-alist
121 (rows . ((align . 0)))
122 (lines . ((align . 1)))
123 (roman . ((font-family . "roman")))
124 (music . ((font-family . "music")))
125 (bold . ((font-series . "bold")))
126 (italic . ((font-shape . "italic")))
127 (named . ((lookup . name)))
128 (super . ((raise . 1) (font-size . "-1")))
129 (sub . ((raise . -1) (font-size . "-1")))
130 (text . ((lookup . value)))
132 (map (lambda (x) (cons (car x) (cons 'font-style (car x))))
133 style-to-font-alist)))
135 (define (markup-to-properties markup)
136 ;;(display "markup: `")
141 (let ((entry (assoc markup markup-abbrev-to-properties-alist)))
142 (if entry (cdr entry)
143 (list (cons markup #t))))))
145 (define (style-to-font-name paper style)
146 (let* ((entry (assoc style style-to-font-alist))
147 (font (if entry (cdr entry) "* * * * * *"))
149 (regexp-substitute/global #f "\\*" font 'pre "[^ ]+" 'post)))
150 (font-regexp-to-font-name paper font-regexp)))