lilypond-1.3.99

diff --git a/VERSION b/VERSION
index 4ec85b0d8c4825c5e16d290ef28472534e0508eb..1a504215d7e399434a9955a90758aca22ae54614 100644 (file)
--- 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 bebdabbad502157415125ecaaa18ae0dd8859ba2..baddf06bb6999e70cb79cbb886da892cefa0c98f 100644 (file)
--- 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 6e455d8e5c78227559b3b2104c19abd4ac31d37f..7d40cc0734d0ca9662160ad7d808e85fe7c5c21f 100644 (file)
--- 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 2f9a88fb45349cb1f79f036410f84fbb44bba002..d11a23a3c8c3bc5d689e83a2ce282abc1f49914c 100644 (file)
--- a/scm/font.scm
+++ b/scm/font.scm
@@ -6,78 +6,141 @@
 ;;; (c) 2000 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
 
-        
-;; 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))
+; )
+