X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Ffont.scm;h=02a408038bff35a9f7ea57fd747554d824dc5e86;hb=d915ae794be635301e275cd659886f4315f78035;hp=92722172ba4aa00c35863a9d70fd5a4377af7462;hpb=a0095a83df6c42fa70051f9c831b209112349463;p=lilypond.git diff --git a/scm/font.scm b/scm/font.scm index 92722172ba..02a408038b 100644 --- a/scm/font.scm +++ b/scm/font.scm @@ -3,7 +3,7 @@ ;;; ;;; source file of the GNU LilyPond music typesetter ;;; -;;; (c) 2000--2001 Jan Nieuwenhuizen +;;; (c) 2000--2003 Jan Nieuwenhuizen ;;; (define style-to-font-alist @@ -19,7 +19,7 @@ ((eq? name 'font-shape) 2) ((eq? name 'font-family) 3) ((eq? name 'font-design-size) 4) - (else (ly-warning "unknown font field name")) + (else (ly:warning "unknown font field name")) ) )) @@ -33,23 +33,24 @@ (define (filter-field field-name value font-descr-alist) "return those descriptions from FONT-DESCR-LIST whose FIELD-NAME matches VALUE" - (filter-list + (filter (lambda (x) (let* (field-value (font-field field-name (car x))) (or (eq? field-value '*) (eq? value field-value)))) font-descr-alist) ) -(define paper-style-sheet-alist + +(define size-independent-fonts `( - ((* * * braces *) . ("feta-braces0" - "feta-braces1" - "feta-braces2" - "feta-braces3" - "feta-braces4" - "feta-braces5" - "feta-braces6" - "feta-braces7" - "feta-braces8") ))) + ((* * * braces *) . ("feta-braces00" + "feta-braces10" + "feta-braces20" + "feta-braces30" + "feta-braces40" + "feta-braces50" + "feta-braces60" + "feta-braces70" + "feta-braces80") ))) ;; FIXME: what about this comment?: @@ -89,14 +90,14 @@ ((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") + ((0 medium italic roman 10) . "cmti10") + ((-1 medium italic roman 8) . "cmti8") + ((-2 medium italic roman 7) . "cmti7") ((-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") + ((4 bold upright roman 17) . "cmbx17") + ((3 bold upright roman 17) . "cmbx17") ((2 bold upright roman 14) . "cmbx14") ((1 bold upright roman 12) . "cmbx12") @@ -225,61 +226,9 @@ paper20-style-sheet-alist)) font-list-alist))) -(define-public (make-style-sheet sym) - `((fonts . ,(append paper-style-sheet-alist - (cdr (assoc sym font-list-alist)))) - (font-defaults - . ((font-family . music) - (font-relative-size . 0) - (font-shape . upright) - (font-series . medium) - )) - (style-alist - . ((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) )) - (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))) - - (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-family . dynamic) (font-relative-size . 0))) - )) - (properties-to-font . - ,Font_interface::properties_to_font_name) - - (markup-to-properties . ,markup-to-properties) - (abbreviation-alist - . ((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))) - (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))) - ) - ) - - ) - ) +(define-public (make-font-list sym) + (append size-independent-fonts + (cdr (assoc sym font-list-alist)))) (define (qualifiers-to-fontnames qualifiers font-descr-alist) " reduce the font list by successively applying a font-qualifier." @@ -340,41 +289,12 @@ 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)))) - (if (pair? handle) - handle - (chain-assoc x (cdr alist-list)))))) +; there used to be a Scheme properties-to-font-name function, +; but that is superseeded by the C++ version out of speed concerns. -;; 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-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))) - - (if (equal? selected "") - (begin - (display "\ncouldn't find any font satisfying " err) - (write qualifiers err) - "cmr10" - ) - selected) ; return the topmost. - )) -(define (markup-to-properties sheet markup) +(define-public (markup-to-properties abbrev-alist style-alist markup) + "DOCME." ;; (display "markup: `") ;; (write markup) ;; (display "'\n") @@ -389,19 +309,18 @@ and warn if the selected font is not unique. (or (not (pair? (cdr markup))) (number? (cadr markup)))) (if (equal? '() (cdr markup)) - (markup-to-properties sheet (car markup)) + (markup-to-properties abbrev-alist style-alist (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-to-properties abbrev-alist style-alist (car markup)) + (append (markup-to-properties abbrev-alist style-alist (car markup)) + (markup-to-properties abbrev-alist style-alist (cdr markup))))) ;; markup is single abbreviation (let ((entry (assoc markup ;; assoc-chain? - (append (cdr (assoc 'abbreviation-alist sheet)) - (cdr (assoc 'style-alist sheet)))))) + (append abbrev-alist style-alist)))) (if entry (cdr entry) (list (cons markup #t)))))) @@ -427,14 +346,30 @@ and warn if the selected font is not unique. (if #f (begin (define (test-module) - (display (filter-list pair? '(1 2 (1 2) (1 .2))) + (display (filter 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)) - ) - ) - ) + (display (style-to-font-name 'paper20 'large))) + ))) + +;;; ascii-script font init +(define as-font-sheet-alist + '((as5 . (((* * * braces *) . ("as-braces9")) + ((* * * number *) . "as-number1") + ((0 * * music *) . ("as5")) + ((0 * * roman *) . "as-dummy"))) + (as9 . (((* * * braces *) . ("as-braces9")) + ((0 medium upright number 10) . "as-number4") + ((* * * number 5) . "as-number1") + ((0 * * music *) . ("as9")) + ((0 * * roman *) . "as-dummy"))))) + +(define-public (as-make-font-list sym) + (set! font-list-alist + (append font-list-alist as-font-sheet-alist)) + (make-font-list sym)) + + -)