X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Ffont.scm;h=e6c46e7ba1d2db7d761b6d212de8e8ba3c7514c8;hb=3a222c318071d27980df7a550c318957c9b2b104;hp=b92027cdd12190038b5946806b157745e8ffed29;hpb=a50dee8c5a1609056cf47df2e17996a85ab358bd;p=lilypond.git diff --git a/scm/font.scm b/scm/font.scm index b92027cdd1..e6c46e7ba1 100644 --- a/scm/font.scm +++ b/scm/font.scm @@ -24,20 +24,6 @@ ) )) -(define (filter-list pred? list) - "return that part of LIST for which PRED is true." - (if (null? list) '() - (let* ( - (rest (filter-list pred? (cdr list))) - ) - (if (pred? (car list)) - (cons (car list) rest) - rest - ) - ) - ) - ) - ;;;;;;;;; TODO TODO . (should not use filtering?) ;; this is bad, since we generate garbage every font-lookup. ;; otoh, if the qualifiers is narrow enough , we don't generate much garbage. @@ -55,6 +41,7 @@ ;; (also tried to vary the order of this list, with little effect) (define paper20-style-sheet-alist '( + ;; why are font-names strings, not symbols? ((3 medium upright number feta-nummer 13) . "feta-nummer13") ((2 medium upright number feta-nummer 13) . "feta-nummer13") ((1 medium upright number feta-nummer 11) . "feta-nummer11") @@ -106,14 +93,31 @@ ((-3 medium upright typewriter cmtt 6) . "cmtt6" ) ((-4 medium upright typewriter cmtt 5) . "cmtt5" ) ((-5 medium upright typewriter cmtt 5) . "cmtt5" ) - - ;; should use the same brace font every where and fix C++ code. - ((2 * * braces feta-braces 26) . "feta-braces26") - ((1 * * braces feta-braces 23) . "feta-braces23") - ((0 * * braces feta-braces 20) . "feta-braces20") - ((-1 * * braces feta-braces 16) . "feta-braces16") - ((-2 * * braces feta-braces 13) . "feta-braces13") - ((-3 * * braces feta-braces 11) . "feta-braces11") + + ((3 medium caps roman cmcsc 12) . "cmcsc12") + ((2 medium caps roman cmcsc 12) . "cmcsc12") + ((1 medium caps roman cmcsc 12) . "cmcsc12") + ((0 medium caps roman cmcsc 10) . "cmcsc10") + ((-1 medium caps roman cmcsc 8) . "cmcsc8") + ((-2 medium caps roman cmcsc 7) . "cmcsc7") + ((-3 medium caps roman cmcsc 7) . "cmcsc7") + + ;; smallest needs 8 steps: -3 to +5, so + ;; biggest also needs 8 available steps: +2 to + 10 + ((10 * * braces feta-braces 3) . "feta-braces3") + ((9 * * braces feta-braces 3) . "feta-braces3") + ((8 * * braces feta-braces 3) . "feta-braces3") + ((7 * * braces feta-braces 3) . "feta-braces3") + ((6 * * braces feta-braces 3) . "feta-braces3") + ((5 * * braces feta-braces 3) . "feta-braces3") + ((4 * * braces feta-braces 2) . "feta-braces2") + ((3 * * braces feta-braces 1) . "feta-braces1") + ((2 * * braces feta-braces 0) . "feta-braces0") + ((1 * * braces feta-braces 0) . "feta-braces0") + ((0 * * braces feta-braces 0) . "feta-braces0") + ((-1 * * braces feta-braces 0) . "feta-braces0") + ((-2 * * braces feta-braces 0) . "feta-braces0") + ((-3 * * braces feta-braces 0) . "feta-braces0") ((3 * * dynamic feta-din 19) . "feta-din19") ((2 * * dynamic feta-din 19) . "feta-din19") @@ -212,13 +216,10 @@ (properties-to-font . ,Font_interface::properties_to_font_name) - ;; FIXME: this is a not-so-cool idea to use ALIGN - ;; RAISE, LOOKUP, since they are not proper elt-properties, - ;; and might interfere with them. (markup-to-properties . ,markup-to-properties) (abbreviation-alist - . ((rows . ((align . 0))) - (lines . ((align . 1))) + . ((columns . ((axis . 0))) + (lines . ((axis . 1))) (roman . ((font-family . roman))) (music . ((font-family . music) (lookup . name))) (finger . ((font-style . finger))) @@ -226,8 +227,9 @@ (upright . ((font-shape . upright))) (italic . ((font-shape . italic))) (named . ((lookup . name))) - (super . ((raise . 1) (font-relative-size . -1))) - (sub . ((raise . -1) (font-relative-size . -1))) + (overstrike . ((extent . (0 . 0)))) + (super . ((raise . 1) (font-relative-size . -1) (extent . (0 . 0)))) + (sub . ((raise . -1) (font-relative-size . -1) (extent . (0 . 0)))) (text . ((lookup . value))) ) ) @@ -246,15 +248,17 @@ ) )) +(define (wild-eq? x y) + (or (eq? x y) + (eq? x '*) + (eq? y '*))) + (define (font-qualifies? qualifiers font-desc) "does FONT-DESC satisfy QUALIFIERS?" (if (null? qualifiers) #t - (if (eq? (font-field (caar qualifiers) font-desc) (cdar qualifiers)) + (if (wild-eq? (font-field (caar qualifiers) font-desc) (cdar qualifiers)) (font-qualifies? (cdr qualifiers) font-desc) - #f - ) - ) - ) + #f))) (define (find-first-font qualifiers fonts) (if (null? fonts) @@ -295,29 +299,27 @@ and warn if the selected font is not unique. (define (chain-assoc x alist-list) (if (null? alist-list) #f - (let* ( - (handle (assoc x (car alist-list))) - ) + (let* ((handle (assoc x (car alist-list)))) (if (pair? handle) handle - (chain-assoc x (cdr alist-list)) - ) - ) - ) - ) + (chain-assoc x (cdr alist-list)))))) ;; TODO ;; the C++ version in font-interface.cc is usually used. +;; +;; FIXME: this has silently been broken by the introduction +;; of wildcards in the font list. (define (properties-to-font-name fonts properties-alist-list) (let* ( ;; change order to change priorities of qualifiers. - (q-order '(font-name font-family font-series font-shape font-design-size font-relative-size)) - (rawqualifiers (map (lambda (x) (chain-assoc x properties-alist-list)) + (q-order '(font-name font-family font-series font-shape + font-design-size font-relative-size)) + (rawqualifiers (map (lambda (x) + (chain-assoc x properties-alist-list)) q-order)) (qualifiers (filter-list pair? rawqualifiers)) - (selected (find-first-font qualifiers fonts)) - (err (current-error-port)) - ) + (selected (find-first-font qualifiers fonts)) + (err (current-error-port))) (if (equal? selected "") (begin @@ -334,7 +336,14 @@ and warn if the selected font is not unique. ;; (display "'\n") (if (pair? markup) - (if (and (symbol? (car markup)) (not (pair? (cdr markup)))) + ;; This is hairy. We want to allow: + ;; ((foo bar) "text") + ;; ((foo (bar . 1)) "text") + ;; ((foo . (0 . 1))) + + (if (and (symbol? (car markup)) + (or (not (pair? (cdr markup))) + (number? (cadr markup)))) (if (equal? '() (cdr markup)) (markup-to-properties sheet (car markup)) (list markup))