X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Ffont.scm;h=b92027cdd12190038b5946806b157745e8ffed29;hb=a50dee8c5a1609056cf47df2e17996a85ab358bd;hp=62fbcb8115b7350bfb6c84ee0ae0b79c5dd0a145;hpb=fdb66b65c89bf9e98da8975999815228d5f0449e;p=lilypond.git diff --git a/scm/font.scm b/scm/font.scm index 62fbcb8115..b92027cdd1 100644 --- a/scm/font.scm +++ b/scm/font.scm @@ -3,7 +3,7 @@ ;;; ;;; source file of the GNU LilyPond music typesetter ;;; -;;; (c) 2000 Jan Nieuwenhuizen +;;; (c) 2000--2001 Jan Nieuwenhuizen ;;; (define style-to-font-alist @@ -19,13 +19,13 @@ ((eq? name 'font-shape) 2) ((eq? name 'font-family) 3) ((eq? name 'font-name) 4) - ((eq? name 'font-point-size) 5) + ((eq? name 'font-design-size) 5) (else (ly-warning "unknown font field name")) ) )) -;; return that part of LIST for which PRED is true. (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))) @@ -42,14 +42,17 @@ ;; this is bad, since we generate garbage every font-lookup. ;; otoh, if the qualifiers is narrow enough , we don't generate much garbage. - -;; return those descriptions from FONT-DESCR-LIST whose FIELD-NAME matches VALUE (define (filter-field field-name value font-descr-alist) + "return those descriptions from FONT-DESCR-LIST whose FIELD-NAME matches VALUE" (filter-list - (lambda (x) (eq? value (font-field field-name (car x)))) + (lambda (x) (let* (field-value (font-field field-name (car x))) + (or (eq? field-value '*) (eq? value field-value)))) font-descr-alist) ) +;; should really have name/pt size at the front of the list. +;; +;; (also tried to vary the order of this list, with little effect) (define paper20-style-sheet-alist '( ((3 medium upright number feta-nummer 13) . "feta-nummer13") @@ -62,79 +65,99 @@ ((-4 medium upright number feta-nummer 5) . "feta-nummer5") ((-5 medium upright number feta-nummer 4) . "feta-nummer4") - ((4 medium upright roman cmr 20) . "cmr20") - ((3 medium upright roman cmr 16) . "cmr16") - ((2 medium upright roman cmr 14) . "cmr14") + ((4 medium upright roman cmr 17) . "cmr17") + ((3 medium upright roman cmr 17) . "cmr17") + ((2 medium upright roman cmr 12) . "cmr12") ((1 medium upright roman cmr 12) . "cmr12") ((0 medium upright roman cmr 10) . "cmr10") ((-1 medium upright roman cmr 8) . "cmr8" ) ((-2 medium upright roman cmr 7) . "cmr7" ) ((-3 medium upright roman cmr 6) . "cmr6" ) ((-4 medium upright roman cmr 5) . "cmr5" ) - ((-5 medium upright roman cmr 4) . "cmr4" ) + ((-5 medium upright roman cmr 5) . "cmr5" ) - ((3 medium italic roman cmti 16) . "cmti16") - ((2 medium italic roman cmti 14) . "cmti14") + ((3 medium italic roman cmti 12) . "cmti12") + ((2 medium italic roman cmti 12) . "cmti12") ((1 medium italic roman cmti 12) . "cmti12") ((0 medium italic roman cmti 10) . "cmti10") ((-1 medium italic roman cmti 8) . "cmti8") ((-2 medium italic roman cmti 7) . "cmti7") - ((-3 medium italic roman cmti 6) . "cmti6") + ((-3 medium italic roman cmti 7) . "cmti7") - ((2 bold upright roman cmbx 14) . "cmbx14") + ((2 bold upright roman cmbx 12) . "cmbx12") ((1 bold upright roman cmbx 12) . "cmbx12") ((0 bold upright roman cmbx 10) . "cmbx10") ((-1 bold upright roman cmbx 8) . "cmbx8") ((-2 bold upright roman cmbx 7) . "cmbx7") + ((2 bold italic roman cmbxti 12) . "cmbxti12") + ((1 bold italic roman cmbxti 12) . "cmbxti12") + ((0 bold italic roman cmbxti 10) . "cmbxti10") + ((-1 bold italic roman cmbxti 8) . "cmbxti8") + ((-2 bold italic roman cmbxti 7) . "cmbxti7") + + ((4 medium upright typewriter cmtt 17) . "cmtt17") + ((3 medium upright typewriter cmtt 17) . "cmtt17") + ((2 medium upright typewriter cmtt 12) . "cmtt12") + ((1 medium upright typewriter cmtt 12) . "cmtt12") + ((0 medium upright typewriter cmtt 10) . "cmtt10") + ((-1 medium upright typewriter cmtt 8) . "cmtt8" ) + ((-2 medium upright typewriter cmtt 7) . "cmtt7" ) + ((-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 medium upright braces feta-braces 26) . "feta-braces26") - ((1 medium upright braces feta-braces 23) . "feta-braces23") - ((0 medium upright braces feta-braces 20) . "feta-braces20") - ((-1 medium upright braces feta-braces 16) . "feta-braces16") - ((-2 medium upright braces feta-braces 13) . "feta-braces13") - ((-3 medium upright braces feta-braces 11) . "feta-braces11") - - ((3 bold italic dynamic feta-din 13) . "feta-din13") - ((2 bold italic dynamic feta-din 13) . "feta-din13") - ((1 bold italic dynamic feta-din 11) . "feta-din11") - ((0 bold italic dynamic feta-din 10) . "feta-din10") - ((-1 bold italic dynamic feta-din 8) . "feta-din8") - ((-2 bold italic dynamic feta-din 7) . "feta-din7") - ((-3 bold italic dynamic feta-din 6) . "feta-din6") - ((-4 bold italic dynamic feta-din 5) . "feta-din5") - ((-5 bold italic dynamic feta-din 4) . "feta-din4") - - ((2 medium upright music feta 26) . "feta26") - ((1 medium upright music feta 23) . "feta23") - ((0 medium upright music feta 20) . "feta20") - ((-0.5 medium upright music feta 20) . "feta19") - ((-1 medium upright music feta 16) . "feta16") - ((-2 medium upright music feta 13) . "feta13") - ((-3 medium upright music feta 11) . "feta11") - ((-4 medium upright music feta 11) . "feta11") - - ((0 medium upright math msam 10) . "msam10") - ((-1 medium upright math msam 10) . "msam10") - ((-2 medium upright math msam 10) . "msam10") - ((-3 medium upright math msam 10) . "msam10") + ((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 * * dynamic feta-din 19) . "feta-din19") + ((2 * * dynamic feta-din 19) . "feta-din19") + ((1 * * dynamic feta-din 17) . "feta-din17") + ((0 * * dynamic feta-din 14) . "feta-din14") + ((-1 * * dynamic feta-din 12) . "feta-din12") + ((-2 * * dynamic feta-din 9) . "feta-din9") + ((-3 * * dynamic feta-din 8) . "feta-din8") + ((-4 * * dynamic feta-din 7) . "feta-din7") + ((-5 * * dynamic feta-din 6) . "feta-din6") + + ((2 * * music feta 26) . "feta26") + ((1 * * music feta 23) . "feta23") + ((0 * * music feta 20) . "feta20") + ((-0.5 * * music feta 20) . "feta19") + ((-1 * * music feta 16) . "feta16") + ((-2 * * music feta 13) . "feta13") + ((-3 * * music feta 11) . "feta11") + ((-4 * * music feta 11) . "feta11") + + ((0 * * math msam 10) . "msam10") + ((-1 * * math msam 10) . "msam10") + ((-2 * * math msam 10) . "msam10") + ((-3 * * math msam 10) . "msam10") )) -;; return a FONT-DESCR with relative size decremented by DECREMENT +;; (define (change-relative-size font-desc decrement) + "return a FONT-DESCR with relative size decremented by DECREMENT" (cons (- (car font-desc) decrement) (cdr font-desc)) ) -;; map a function FUNC over the keys of an alist LIST, leaving the vals. +;; (define (map-alist-keys func list) + "map a function FUNC over the keys of an alist LIST, leaving the vals. " (if (null? list) '() (cons (cons (func (caar list)) (cdar list)) (map-alist-keys func (cdr list))) )) -;; map a function FUNC over the vals of LIST, leaving the keys. +;; (define (map-alist-vals func list) + "map a function FUNC over the vals of LIST, leaving the keys." (if (null? list) '() (cons (cons (caar list) (func (cdar list))) @@ -172,7 +195,9 @@ . ((finger . ((font-family . number) (font-relative-size . -3))) (volta . ((font-family . number) (font-relative-size . -2))) (tuplet . ((font-family . roman) (font-shape . italic) (font-relative-size . -1))) - (timesig . ((font-family . number) (font-relative-size . 0))) + + (timesig . ((font-family . number) (font-relative-size . 0))) + (timesig-symbol . ((font-family . music) (font-relative-size . 0))) (mmrest . ((font-family . number) (font-relative-size . 1))) (mmrest-symbol . ((font-family . music) (font-relative-size . 0))) @@ -180,10 +205,12 @@ (mark . ((font-family . number) (font-relative-size . 1))) (script . ((font-family . roman) (font-relative-size . -1))) (large . ((font-family . roman) (font-relative-size . 1))) - (Large . ((font-series . bold) (font-family . roman) (font-relative-size . 2))) - (dynamic . ((font-series . bold) (font-family . dynamic) (font-relative-size . 0))) + (Large . ((font-series . bold) (font-family . roman) + (font-relative-size . 2))) + (dynamic . ((font-family . dynamic) (font-relative-size . 0))) )) - (properties-to-font . ,properties-to-font-name) + (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, @@ -193,9 +220,10 @@ . ((rows . ((align . 0))) (lines . ((align . 1))) (roman . ((font-family . roman))) - (music . ((font-family . music) (font-shape . upright))) + (music . ((font-family . music) (lookup . name))) (finger . ((font-style . finger))) (bold . ((font-series . bold))) + (upright . ((font-shape . upright))) (italic . ((font-shape . italic))) (named . ((lookup . name))) (super . ((raise . 1) (font-relative-size . -1))) @@ -207,8 +235,8 @@ ) ) -;; reduce the font list by successively applying a font-qualifier. (define (qualifiers-to-fontnames qualifiers font-descr-alist) + " reduce the font list by successively applying a font-qualifier." (if (null? qualifiers) font-descr-alist @@ -218,9 +246,8 @@ ) )) - -;; does FONT-DESC satisfy QUALIFIERS? (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)) (font-qualifies? (cdr qualifiers) font-desc) @@ -239,9 +266,10 @@ )) -;; return a single font from FONTS (or a default, if none found) -;; and warn if the selected font is not unique. (define (select-unique-font qualifiers fonts) + "return a single font from FONTS (or a default, if none found) +and warn if the selected font is not unique. +" (let* ( (err (current-error-port)) ) @@ -252,11 +280,11 @@ (display "\ncouldn't find unique font satisfying " err) (write qualifiers err) (display " found " err) - (if (null? fonts) - (display "none" err) - (write (map cdr fonts) err)) - )) - + (if (null? fonts) + (display "none" err) + (write (map cdr fonts) err)) + )) + (if (null? fonts) "cmr10" (cdar fonts)) ; return the topmost. @@ -279,13 +307,11 @@ ) ;; TODO -;; add support for override by font-name -;; very often-used; hard-code in C++, and use SCM glue code. - +;; the C++ version in font-interface.cc is usually used. (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-point-size font-relative-size)) + (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)) @@ -303,11 +329,22 @@ )) (define (markup-to-properties sheet markup) - ;;(display "markup: `") - ;;(write markup) - ;;(display "'\n") + ;; (display "markup: `") + ;; (write markup) + ;; (display "'\n") + (if (pair? markup) - (list markup) + (if (and (symbol? (car markup)) (not (pair? (cdr markup)))) + (if (equal? '() (cdr markup)) + (markup-to-properties sheet (car markup)) + (list markup)) + + (if (equal? '() (cdr markup)) + (markup-to-properties sheet (car markup)) + (append (markup-to-properties sheet (car markup)) + (markup-to-properties sheet (cdr markup))))) + + ;; markup is single abbreviation (let ((entry (assoc markup ;; assoc-chain? (append (cdr (assoc 'abbreviation-alist sheet)) @@ -316,6 +353,7 @@ (cdr entry) (list (cons markup #t)))))) + ; fixme, how's this supposed to work? ; and why don't we import font-setting from elt? (define (style-to-font-name sheet style) @@ -334,15 +372,16 @@ font) ; return the topmost. )) +(if #f (begin + (define (test-module) + (display (filter-list pair? '(1 2 (1 2) (1 .2))) + (display (filter-field 'font-name 'cmbx paper20-style-sheet-alist)) + (display (qualifiers-to-fontname '((font-name . cmbx)) paper20-style-sheet-alist)) + (display (style-to-font-name 'paper20 'large)) + ) + ) + ) -; (define (test-module) -; (display (filter-list pair? '(1 2 (1 2) (1 .2))) -;(display (filter-field 'font-name 'cmbx paper20-style-sheet-alist)) - -; (display (qualifiers-to-fontname '((font-name . cmbx)) paper20-style-sheet-alist)) -; (display (style-to-font-name 'paper20 'large)) -; ) - - +)