From a8299b207f301268e2babede93507d608e031b91 Mon Sep 17 00:00:00 2001 From: fred Date: Wed, 27 Mar 2002 00:01:38 +0000 Subject: [PATCH] lilypond-1.3.99 --- VERSION | 2 +- lily/property-engraver.cc | 10 +- lily/translator-group.cc | 32 +---- scm/font.scm | 287 ++++++++++++++++++++++++++------------ 4 files changed, 211 insertions(+), 120 deletions(-) diff --git a/VERSION b/VERSION index 4ec85b0d8c..1a504215d7 100644 --- a/VERSION +++ b/VERSION @@ -1,7 +1,7 @@ PACKAGE_NAME=LilyPond MAJOR_VERSION=1 MINOR_VERSION=3 -PATCH_LEVEL=98 +PATCH_LEVEL=99 MY_PATCH_LEVEL= # use the above to send patches: MY_PATCH_LEVEL is always empty for a diff --git a/lily/property-engraver.cc b/lily/property-engraver.cc index bebdabbad5..baddf06bb6 100644 --- a/lily/property-engraver.cc +++ b/lily/property-engraver.cc @@ -127,13 +127,9 @@ Property_engraver::apply_properties (SCM p, Score_element *e, Translator_group*o name = scm_assoc (ly_symbol2scm ("name"), name); scm_display (gh_cdr(name), errport); scm_puts(" \\push #'",errport); - scm_display (elt_prop_sym,errport); + scm_write (elt_prop_sym,errport); scm_puts ( " = #",errport); - if (gh_string_p (val)) - scm_puts ("\"", errport); - scm_display (val, scm_current_error_port ()); - if (gh_string_p (val)) - scm_puts ("\"", errport); + scm_write (val, scm_current_error_port ()); scm_puts ("\n", errport); } else @@ -159,7 +155,7 @@ Property_engraver::apply_properties (SCM p, Score_element *e, Translator_group*o scm_display (gh_call1 (typefunc, type_p), errport); scm_puts (", value found: ", errport); - scm_display (val, errport); + scm_write (val, errport); scm_puts (" type: ", errport); scm_display (ly_type (val), errport); scm_puts ("\n", errport); diff --git a/lily/translator-group.cc b/lily/translator-group.cc index 6e455d8e5c..7d40cc0734 100644 --- a/lily/translator-group.cc +++ b/lily/translator-group.cc @@ -207,24 +207,6 @@ Translator_group::remove_translator_p (Translator*trans_l) return trans_l; } -#if 0 -/* - should not use, instead: use properties to communicate between engravers. - */ -Translator* -Translator_group::get_simple_translator (String type) const -{ - for (SCM p = simple_trans_list_; gh_pair_p (p); p =gh_cdr (p)) - { - if (classname (unsmob_translator (gh_car (p))) == type) - return unsmob_translator (gh_car (p)); - } - if (daddy_trans_l_) - return daddy_trans_l_->get_simple_translator (type); - return 0; -} -#endif - bool Translator_group::is_bottom_translator_b () const { @@ -349,8 +331,8 @@ Translator_group::execute_single_pushpop_property (SCM prop, SCM eltprop, SCM va SCM meta = scm_assoc (ly_symbol2scm ("meta"), prev); SCM props = scm_assoc (ly_symbol2scm ("properties"), gh_cdr (meta)); - SCM propdesc = scm_assoc (eltprop, gh_cdr (props)); - if (!gh_pair_p (propdesc)) + SCM type_p = scm_assoc (eltprop, gh_cdr (props)); + if (!gh_pair_p (type_p)) { scm_puts (_("Couldn't find property description for #'").ch_C(),errport); scm_display (eltprop, errport); @@ -362,19 +344,17 @@ Translator_group::execute_single_pushpop_property (SCM prop, SCM eltprop, SCM va } else { - - SCM predicate = gh_cadr (propdesc); - if (gh_call1 (predicate, val) == SCM_BOOL_F) + type_p = gh_cdr (type_p); + if (gh_call1 (type_p, val) == SCM_BOOL_F) { ok = false; scm_puts (_("Failed typecheck for #'").ch_C (),errport); scm_display (eltprop,errport); scm_puts ( _(", value ").ch_C (), errport); - scm_display (val, errport); + scm_write (val, errport); scm_puts (_(" must be of type ").ch_C (), errport); SCM typefunc = scm_eval2 (ly_symbol2scm ("type-name"), SCM_EOL); - - scm_display (gh_call1 (typefunc, predicate), errport); + scm_display (gh_call1 (typefunc, type_p), errport); scm_puts ("\n", errport); } } diff --git a/scm/font.scm b/scm/font.scm index 2f9a88fb45..d11a23a3c8 100644 --- a/scm/font.scm +++ b/scm/font.scm @@ -6,78 +6,141 @@ ;;; (c) 2000 Jan Nieuwenhuizen ;;; - -;; Corresponding properties: -;; -;; font-series font-shape font-family font-name font-point font-size -;; - (define style-to-font-alist - '( - (finger . "* * number * * -4") - (volta . "* * number * * -3") - (timesig . "* * number * * 0") - (mark . "* * number * * 2") - (script . "* * roman * * -1") - (large . "* * roman * * 1") - (Large . "bold * roman * * 2") - (dynamic . "bold * dynamic * * 0") - )) + `( + (finger . ((font-family . number) (font-relative-size . -3))) + (volta . ((font-family . number) (font-relative-size . -2))) + (timesig . ((font-family . number) (font-relative-size . 0))) + (mmrest . ((font-family . number) (font-relative-size . -1))) + (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))) +)) + +(define (font-field name font-descr) + (list-ref + font-descr + (cond + ((eq? name 'font-relative-size) 0) + ((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-size) 5) + ) + )) + +;; return that part of LIST for which PRED is true. +(define (filter-list pred? list) + (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. + -(define paper20-style-sheet-alist-template +;; return those descriptions from FONT-DESCR-LIST whose FIELD-NAME matches VALUE +(define (filter-field field-name value font-descr-alist) + (filter-list + (lambda (x) (eq? value (font-field field-name (car x)))) + font-descr-alist) + ) + +(define paper20-style-sheet-alist '( - (("medium upright music feta 20" . 0) . "feta20") - (("medium upright music feta 16" . -1) . "feta16") - (("medium upright music feta 13" . -2) . "feta13") - (("medium upright music feta 23" . 1) . "feta23") - (("medium upright music feta 26" . 2) . "feta26") - (("medium upright braces feta-braces 20" . 0) . "feta-braces20") - (("bold italic dynamic feta 10" . 0) . "feta-din10") - ;; Hmm - (("medium upright number feta-nummer 13" . 3) . "feta-nummer13") - (("medium upright number feta-nummer 13" . 2) . "feta-nummer13") - (("medium upright number feta-nummer 12" . 1) . "feta-nummer12") - (("medium upright number feta-nummer 10" . 0) . "feta-nummer10") - (("medium upright number feta-nummer 8" . -1) . "feta-nummer8") - (("medium upright number feta-nummer 6" . -2) . "feta-nummer6") - (("medium upright number feta-nummer 5" . -3) . "feta-nummer5") - (("medium upright number feta-nummer 4" . -4) . "feta-nummer4") - (("medium upright number feta-nummer 3" . -5) . "feta-nummer3") - (("medium upright roman cmr 8" . -1) . "cmr8" ) - (("medium upright roman cmr 10" . 0) . "cmr10") - (("medium upright roman cmr 12" . 1) . "cmr12") - (("bold upright roman cmbx 10" . 0) . "cmbx10") - (("bold upright roman cmbx 12" . 1) . "cmbx12") - (("medium italic roman cmbx 10" . 0) . "cmbx10") - (("medium italic roman cmbx 12" . 1) . "cmbx12") - (("medium upright math msam 10" . -2) . "msam10") - (("medium upright math msam 10" . -1) . "msam10") - (("medium upright math msam 10" . 0) . "msam10") + ((0 medium upright music feta 20) . "feta20") + ((-1 medium upright music feta 16) . "feta16") + ((-2 medium upright music feta 13) . "feta13") + ((-3 medium upright music feta 13) . "feta11") + ((-4 medium upright music feta 13) . "feta11") + ((1 medium upright music feta 23) . "feta23") + ((2 medium upright music feta 26) . "feta26") + ((0 medium upright braces feta-braces 20) . "feta-braces20") + ((0 medium italic roman cmti 10) . "cmti10") + ((1 medium italic roman cmti 12) . "cmti12") + ((3 bold italic dynamic feta 10) . "feta-din13") + ((2 bold italic dynamic feta 10) . "feta-din13") + ((1 bold italic dynamic feta 10) . "feta-din12") + ((0 bold italic dynamic feta 10) . "feta-din10") + ((-1 bold italic dynamic feta 10) . "feta-din8") + ((-2 bold italic dynamic feta 10) . "feta-din7") + ((-3 bold italic dynamic feta 10) . "feta-din6") + ((-4 bold italic dynamic feta 10) . "feta-din5") + ((-5 bold italic dynamic feta 10) . "feta-din4") + ((3 medium upright number feta-nummer 13) . "feta-nummer13") + ((2 medium upright number feta-nummer 13) . "feta-nummer13") + ((1 medium upright number feta-nummer 12) . "feta-nummer12") + ((0 medium upright number feta-nummer 10) . "feta-nummer10") + ((-1 medium upright number feta-nummer 8) . "feta-nummer8") + ((-2 medium upright number feta-nummer 6) . "feta-nummer6") + ((-3 medium upright number feta-nummer 5) . "feta-nummer5") + ((-4 medium upright number feta-nummer 4) . "feta-nummer4") + ((0 medium upright roman cmr 10) . "cmr10") + ((1 medium upright roman cmr 12) . "cmr12") + ((-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" ) + ((2 bold upright roman cmbx 10) . "cmbx10") + ((1 bold upright roman cmbx 12) . "cmbx12") + ((-3 medium upright math msam 10) . "msam10") + ((-2 medium upright math msam 10) . "msam10") + ((-1 medium upright math msam 10) . "msam10") + ((0 medium upright math msam 10) . "msam10") )) -(define (style-sheet-template-entry-compile entry size) - (cons - (string-append (caar entry) - " " - (number->string (- (cdar entry) size)) - " ") - (cdr entry))) - + +;; return a FONT-DESCR with relative size incremented by INCREMENT +(define (change-relative-size font-desc increment) + (cons (+ increment (car font-desc)) (cdr font-desc)) + ) + +;; map a function FUNC over the keys of an alist LIST, leaving the vals. +(define (map-alist-keys func list) + (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) + (if (null? list) + '() + (cons (cons (caar list) (func (cdar list))) + (map-alist-vals func (cdr list))) + )) + +(define (change-style-sheet-relative-size sheet x) + (map-alist-keys (lambda (descr) (change-relative-size descr x)) sheet)) + + +;; make style sheet for each paper version. (define style-sheet-alist - `( - (paper11 . ,(map (lambda (x) (style-sheet-template-entry-compile x -3)) - paper20-style-sheet-alist-template)) - (paper13 . ,(map (lambda (x) (style-sheet-template-entry-compile x -2)) - paper20-style-sheet-alist-template)) - (paper16 . ,(map (lambda (x) (style-sheet-template-entry-compile x -1)) - paper20-style-sheet-alist-template)) - (paper20 . ,(map (lambda (x) (style-sheet-template-entry-compile x 0)) - paper20-style-sheet-alist-template)) - (paper23 . ,(map (lambda (x) (style-sheet-template-entry-compile x 1)) - paper20-style-sheet-alist-template)) - (paper26 . ,(map (lambda (x) (style-sheet-template-entry-compile x 2)) - paper20-style-sheet-alist-template)) - )) + (map-alist-vals (lambda (x) (change-style-sheet-relative-size + paper20-style-sheet-alist x)) + '((paper11 . -3) + (paper13 . -2) + (paper16 . -1) + (paper20 . 0) + (paper23 . 1) + (paper26 . 2) + )) + ) + (define (font-regexp-to-font-name paper regexp) (let ((style-sheet (cdr (assoc paper style-sheet-alist)))) @@ -88,35 +151,66 @@ (loop (cdr fonts)) '()))))) +;; reduce the font list by successively applying a font-qualifier. +(define (qualifiers-to-fontname qualifiers font-descr-alist) + (if (null? qualifiers) + (if (null? font-descr-alist) + "" + (cdar font-descr-alist)) ; return the topmost. + + (qualifiers-to-fontname + (cdr qualifiers) + (filter-field (caar qualifiers) (cdar qualifiers) font-descr-alist) + ) + )) + (define (properties-to-font-name paper properties-alist) - (let ((font-regexp (apply string-append - (map (lambda (key) - (string-append - (let ((entry (assoc key properties-alist))) - (if entry (cdr entry) "[^ ]+")) - " ")) - '(font-series font-shape font-family font-name font-point font-size))))) - (font-regexp-to-font-name paper font-regexp))) + (let* ( + (fonts (cdr (assoc paper style-sheet-alist))) + + ;; 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) (assoc x properties-alist)) + q-order)) + + (qualifiers (filter-list pair? rawqualifiers)) + (fontnm (qualifiers-to-fontname qualifiers fonts)) + (err (current-error-port)) + ) + + (if (eq? fontnm "") + (begin + (display "\ncouldn't find font satisfying " err) + (write qualifiers err) + (display "\n" err) + "cmr10" + ) + fontnm) + + + )) + (define markup-abbrev-to-properties-alist (append '( (rows . ((align . 0))) (lines . ((align . 1))) - (roman . ((font-family . "roman"))) - (music . ((font-family . "music"))) - (bold . ((font-series . "bold"))) - (italic . ((font-shape . "italic"))) + (roman . ((font-family . roman))) + (music . ((font-family . music))) + (finger . ((font-style . finger))) + (bold . ((font-series . bold))) + (italic . ((font-shape . italic))) (named . ((lookup . name))) - (super . ((raise . 1) (font-size . "-1"))) - (sub . ((raise . -1) (font-size . "-1"))) + (super . ((raise . 1) (font-relative-size . -1))) + (sub . ((raise . -1) (font-relative-size . -1))) (text . ((lookup . value))) ) (map (lambda (x) (cons (car x) (cons 'font-style (car x)))) style-to-font-alist))) (define (markup-to-properties markup) - ;; (display "markup: `") + ;;(display "markup: `") ;;(display markup) ;;(display "'\n") (if (pair? markup) @@ -124,11 +218,32 @@ (let ((entry (assoc markup markup-abbrev-to-properties-alist))) (if entry (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 paper style) (let* ((entry (assoc style style-to-font-alist)) - (font (if entry (cdr entry) "* * * * * *")) - (font-regexp - (regexp-substitute/global #f "\\*" font 'pre "[^ ]+" 'post))) - (font-regexp-to-font-name paper font-regexp))) + (qs (if entry (cdr entry) '())) + (sheet (cdr (assoc paper style-sheet-alist))) + (fontnm (qualifiers-to-fontname qs sheet)) + (err (current-error-port))) + (if (eq? fontnm "") + (begin + (display "\ncouldn't find font satisfying " err) + (display qs err) + (display "\n" err) + "cmr10") + fontnm))) + + + + +; (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)) +; ) + -- 2.39.5