X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Ffont.scm;h=f72a401b67884b8c46c480b4c372d55a73b79f5f;hb=3471866d047b2e22f6d42eedb936d5eddcb5a06a;hp=fe66eb1d9f86c0412c9bac724328667586b51462;hpb=343637e19d2690386903e8a7829ce55ef2c8e048;p=lilypond.git diff --git a/scm/font.scm b/scm/font.scm index fe66eb1d9f..f72a401b67 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 @@ -18,27 +18,16 @@ ((eq? name 'font-series) 1) ((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) 4) (else (ly-warning "unknown font field name")) ) )) - -(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?) + + +;; most of these routines have been reimplemented in C++ + +;; 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. @@ -50,88 +39,123 @@ font-descr-alist) ) -;; should really have name/pt size at the front of the list. +(define paper-style-sheet-alist + '( + ((8 * * braces 8) . "feta-braces8") + ((7 * * braces 7) . "feta-braces7") + ((6 * * braces 6) . "feta-braces6") + ((5 * * braces 5) . "feta-braces5") + ((4 * * braces 4) . "feta-braces4") + ((3 * * braces 3) . "feta-braces3") + ((2 * * braces 2) . "feta-braces2") + ((1 * * braces 1) . "feta-braces1") + ((0 * * braces 0) . "feta-braces0") + )) + +;; FIXME: what about this comment?: +;; should really have name/pt size at the front of the list. +;; (also tried to vary the order of this list, with little effect) ;; -;; (also tried to vary the order of this list, with little effect) +;; (font-relative-size font-series font-shape font-family +;; font-design-size) (define paper20-style-sheet-alist '( - ((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") - ((0 medium upright number feta-nummer 10) . "feta-nummer10") - ((-1 medium upright number feta-nummer 8) . "feta-nummer8") - ((-2 medium upright number feta-nummer 7) . "feta-nummer7") - ((-3 medium upright number feta-nummer 6) . "feta-nummer6") - ((-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") - ((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" ) - - ((3 medium italic roman cmti 16) . "cmti16") - ((2 medium italic roman cmti 14) . "cmti14") - ((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") - - ((2 bold upright roman cmbx 14) . "cmbx14") - ((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") + ;; why are font file names strings, not symbols? + ((3 medium upright number 13) . "feta-nummer13") + ((2 medium upright number 13) . "feta-nummer13") + ((1 medium upright number 11) . "feta-nummer11") + ((0 medium upright number 10) . "feta-nummer10") + ((-1 medium upright number 8) . "feta-nummer8") + ((-2 medium upright number 7) . "feta-nummer7") + ((-3 medium upright number 6) . "feta-nummer6") + ((-4 medium upright number 5) . "feta-nummer5") + ((-5 medium upright number 4) . "feta-nummer4") + + ((4 medium upright roman 17) . "cmr17") + ((3 medium upright roman 17) . "cmr17") + ((2 medium upright roman 12) . "cmr12") + ((1 medium upright roman 12) . "cmr12") + ((0 medium upright roman 10) . "cmr10") + ((-1 medium upright roman 8) . "cmr8" ) + ((-2 medium upright roman 7) . "cmr7" ) + ((-3 medium upright roman 6) . "cmr6" ) + ((-4 medium upright roman 5) . "cmr5" ) + ((-5 medium upright roman 5) . "cmr5" ) + + ((3 medium italic roman 12) . "cmti12") + ((2 medium italic roman 12) . "cmti12") + ((1 medium italic roman 12) . "cmti12") ;;; ugh. Should add magnification here! + ((0 medium italic roman 10) . "cmti12") + ((-1 medium italic roman 8) . "cmti10") + ((-2 medium italic roman 7) . "cmti8") + ((-3 medium italic roman 7) . "cmti7") + + ;;; cmbx17 is sauter, not commonly available as Type1. + ((4 bold upright roman 17) . "cmr17") + ((3 bold upright roman 17) . "cmr17") + + ((2 bold upright roman 14) . "cmbx14") + ((1 bold upright roman 12) . "cmbx12") + ((0 bold upright roman 10) . "cmbx10") + ((-1 bold upright roman 8) . "cmbx8") + ((-2 bold upright roman 7) . "cmbx7") + + ((2 bold italic roman 12) . "cmbxti12") + ((1 bold italic roman 12) . "cmbxti12") + ((0 bold italic roman 10) . "cmbxti10") + + ((-1 bold italic roman 8) . "cmbxti8") + ((-2 bold italic roman 7) . "cmbxti7") - ((4 medium upright typewriter cmtt 20) . "cmtt20") - ((3 medium upright typewriter cmtt 16) . "cmtt16") - ((2 medium upright typewriter cmtt 14) . "cmtt14") - ((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 4) . "cmtt4" ) - - ;; 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 * * 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") + ((4 medium upright typewriter 17) . "cmtt17") + ((3 medium upright typewriter 17) . "cmtt17") + ((2 medium upright typewriter 12) . "cmtt12") + ((1 medium upright typewriter 12) . "cmtt12") + ((0 medium upright typewriter 10) . "cmtt10") + ((-1 medium upright typewriter 8) . "cmtt8" ) + ((-2 medium upright typewriter 7) . "cmtt7" ) + ((-3 medium upright typewriter 6) . "cmtt6" ) + ((-4 medium upright typewriter 5) . "cmtt5" ) + ((-5 medium upright typewriter 5) . "cmtt5" ) + + ((3 medium caps roman 12) . "cmcsc12") + ((2 medium caps roman 12) . "cmcsc12") + ((1 medium caps roman 12) . "cmcsc12") + ((0 medium caps roman 10) . "cmcsc10") + ((-1 medium caps roman 8) . "cmcsc8") + ((-2 medium caps roman 7) . "cmcsc7") + ((-3 medium caps roman 7) . "cmcsc7") + + ((3 * * dynamic 19) . "feta-din19") + ((2 * * dynamic 19) . "feta-din19") + ((1 * * dynamic 17) . "feta-din17") + ((0 * * dynamic 14) . "feta-din14") + ((-1 * * dynamic 12) . "feta-din12") + ((-2 * * dynamic 9) . "feta-din9") + ((-3 * * dynamic 8) . "feta-din8") + ((-4 * * dynamic 7) . "feta-din7") + ((-5 * * dynamic 6) . "feta-din6") + + ((2 * * music 26) . "feta26") + ((1 * * music 23) . "feta23") + ((0 * * music 20) . "feta20") + ((-1 * * music 16) . "feta16") + ((-2 * * music 13) . "feta13") + ((-3 * * music 11) . "feta11") + ((-4 * * music 11) . "feta11") + + ((2 * * ancient 26) . "parmesan26") + ((1 * * ancient 23) . "parmesan23") + ((0 * * ancient 20) . "parmesan20") + ((-1 * * ancient 16) . "parmesan16") + ((-2 * * ancient 13) . "parmesan13") + ((-3 * * ancient 11) . "parmesan11") + ((-4 * * ancient 11) . "parmesan11") + + ((0 * * math 10) . "msam10") + ((-1 * * math 10) . "msam10") + ((-2 * * math 10) . "msam10") + ((-3 * * math 10) . "msam10") )) ;; @@ -140,6 +164,13 @@ (cons (- (car font-desc) decrement) (cdr font-desc)) ) +(define (change-rhs-size font-desc from to ) + (cons (car font-desc) + (regexp-substitute/global #f from (cdr font-desc) 'pre to 'post)) + + ) + + ;; (define (map-alist-keys func list) "map a function FUNC over the keys of an alist LIST, leaving the vals. " @@ -149,6 +180,7 @@ (map-alist-keys func (cdr list))) )) + ;; (define (map-alist-vals func list) "map a function FUNC over the vals of LIST, leaving the keys." @@ -169,16 +201,23 @@ '((paper11 . -3) (paper13 . -2) (paper16 . -1) - (paper19 . -0.5) (paper20 . 0) (paper23 . 1) (paper26 . 2) )) ) +(set! font-list-alist + (cons + (cons + 'paper19 + (map (lambda (x) (change-rhs-size x "20" "19")) + paper20-style-sheet-alist)) + font-list-alist)) (define (make-style-sheet sym) - `((fonts . ,(cdr (assoc sym font-list-alist))) + `((fonts . ,(append paper-style-sheet-alist + (cdr (assoc sym font-list-alist)))) (font-defaults . ((font-family . music) (font-relative-size . 0) @@ -190,37 +229,41 @@ (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-symbol . ((font-family . music) (font-relative-size . 0))) + (timesig . ((font-family . number) )) + (timesig-symbol . ((font-family . music) )) + + (mmrest . ((font-family . number) )) + (mmrest-symbol . ((font-family . music) )) + + (mark-number . ((font-family . number) (font-relative-size . 1))) + (mark-letter . ((font-family . roman) + (font-series . bold) + (font-shape . upright) + (font-relative-size . 2))) - (mmrest . ((font-family . number) (font-relative-size . 1))) - (mmrest-symbol . ((font-family . music) (font-relative-size . 0))) - - (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-shape . upright) - (font-family . roman) (font-relative-size . 2))) + (Large . ((font-series . bold) (font-family . roman) + (font-relative-size . 2))) (dynamic . ((font-family . dynamic) (font-relative-size . 0))) )) (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))) (bold . ((font-series . bold))) + (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))) ) ) @@ -239,15 +282,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) @@ -288,29 +333,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-point-size font-relative-size)) - (rawqualifiers (map (lambda (x) (chain-assoc x properties-alist-list)) + (q-order '(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 @@ -322,11 +365,29 @@ and warn if the selected font is not unique. )) (define (markup-to-properties sheet markup) - ;;(display "markup: `") - ;;(write markup) - ;;(display "'\n") + ;; (display "markup: `") + ;; (write markup) + ;; (display "'\n") + (if (pair? markup) - (list 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)) + + (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)) @@ -335,6 +396,7 @@ and warn if the selected font is not unique. (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)