remove tail, filter-list, filter-out-list,

[lilypond.git] / scm / font.scm

diff --git a/scm/font.scm b/scm/font.scm
index 116382de82236e6911b92f0703dc103016561222..fa6835c34092e09307a075f1dfb7c85b07d0f81c 100644 (file)
--- a/scm/font.scm
+++ b/scm/font.scm
@@ -3,7 +3,7 @@
 ;;;
 ;;; source file of the GNU LilyPond music typesetter
 ;;; 
 ;;;
 ;;; source file of the GNU LilyPond music typesetter
 ;;; 

-;;; (c) 2000--2001 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; (c)  2000--2003 Jan Nieuwenhuizen <janneke@gnu.org>

 ;;;
 
 (define style-to-font-alist
 ;;;
 
 (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)
        ((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,13 +33,14 @@
 
 (define (filter-field field-name value font-descr-alist)
   "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
+      (filter

        (lambda (x) (let* (field-value (font-field field-name (car x))) 
                     (or (eq? field-value '*) (eq? value field-value))))
        font-descr-alist)
       )
 
        (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"
   `(
     ((* * * braces *) . ("feta-braces0"
                         "feta-braces1"


@@ -61,6 +62,7 @@
 ;;
 ;; (font-relative-size font-series font-shape font-family 
 ;; font-design-size)
 ;;
 ;; (font-relative-size font-series font-shape font-family 
 ;; font-design-size)

+

 (define paper20-style-sheet-alist
   '(
     ;; why are font file names strings, not symbols?
 (define paper20-style-sheet-alist
   '(
     ;; why are font file names strings, not symbols?


@@ -88,9 +90,9 @@
     ((3 medium italic roman 12) . "cmti12")
     ((2 medium italic roman 12) . "cmti12")
     ((1 medium italic roman 12) . "cmti12") ;;; ugh. Should add magnification here! 
     ((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.
     ((-3 medium italic roman 7) . "cmti7")    
 
     ;;; cmbx17 is sauter, not commonly available as Type1.


@@ -224,61 +226,9 @@
             paper20-style-sheet-alist))
        font-list-alist)))
 
             paper20-style-sheet-alist))
        font-list-alist)))
 

-(define (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."
 
 (define (qualifiers-to-fontnames  qualifiers font-descr-alist)
   " reduce the font list by successively applying a font-qualifier."


@@ -339,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")
   ;; (display "markup: `")
   ;; (write markup)
   ;; (display "'\n")


@@ -388,19 +309,18 @@ and warn if the selected font is not unique.
               (or (not (pair? (cdr markup)))
                   (number? (cadr markup))))
          (if (equal? '() (cdr markup))
               (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))
              (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?
       
       ;; 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))))))
        (if entry
            (cdr entry)
            (list (cons markup #t))))))


@@ -426,7 +346,7 @@ and warn if the selected font is not unique.
 
 (if #f (begin
         (define (test-module)
 
 (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 (filter-field 'font-name 'cmbx paper20-style-sheet-alist))
                    
                    (display (qualifiers-to-fontname '((font-name . cmbx)) paper20-style-sheet-alist))


@@ -437,3 +357,24 @@ and warn if the selected font is not unique.
 
 
 )
 
 
 )

+
+;;; 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))
+
+
+
+