scm/font.scm

   1 ;;;
   2 ;;; font.scm -- implement Font stuff
   3 ;;;
   4 ;;; source file of the GNU LilyPond music typesetter
   5 ;;;
   6 ;;; (c) 2000 Jan Nieuwenhuizen <janneke@gnu.org>
   7 ;;;
   8
   9
  10 ;; Corresponding properties:
  11 ;;
  12 ;;   font-series font-shape font-family font-name font-point font-size
  13 ;;
  14
  15 (define style-to-font-alist
  16   '(
  17     (finger . "* * number * * -4")
  18     (volta . "* * number * * -3")
  19     (timesig . "* * number * * 0")
  20     (mark . "* * number * * 2")
  21     (script . "* * roman * * -1")
  22     (large . "* * roman * * 1")
  23     (Large . "bold * roman * * 2")
  24     (dynamic . "bold * dynamic * * 0")
  25     ))
  26
  27 (define paper20-style-sheet-alist-template
  28   '(
  29     (("medium upright music feta 20" . 0) . "feta20")
  30     (("medium upright music feta 16" . -1) . "feta16")
  31     (("medium upright music feta 13" . -2) . "feta13")
  32     (("medium upright music feta 23" . 1) . "feta23")
  33     (("medium upright music feta 26" . 2) . "feta26")
  34     (("medium upright braces feta-braces 20" . 0) . "feta-braces20")
  35     (("bold italic dynamic feta 10" . 0) . "feta-din10")
  36     ;; Hmm
  37     (("medium upright number feta-nummer 13" . 3) . "feta-nummer13")
  38     (("medium upright number feta-nummer 13" . 2) . "feta-nummer13")
  39     (("medium upright number feta-nummer 12" . 1) . "feta-nummer12")
  40     (("medium upright number feta-nummer 10" . 0) . "feta-nummer10")
  41     (("medium upright number feta-nummer 8" . -1) . "feta-nummer8")
  42     (("medium upright number feta-nummer 6" . -2) . "feta-nummer6")
  43     (("medium upright number feta-nummer 5" . -3) . "feta-nummer5")
  44     (("medium upright number feta-nummer 4" . -4) . "feta-nummer4")
  45     (("medium upright number feta-nummer 3" . -5) . "feta-nummer3")
  46     (("medium upright roman cmr 8" . -1) . "cmr8" )
  47     (("medium upright roman cmr 10" . 0) . "cmr10")
  48     (("medium upright roman cmr 12" . 1) . "cmr12")
  49     (("bold upright roman cmbx 10" . 0) . "cmbx10")
  50     (("bold upright roman cmbx 12" . 1) . "cmbx12")
  51     (("medium italic roman cmbx 10" . 0) . "cmbx10")
  52     (("medium italic roman cmbx 12" . 1) . "cmbx12")
  53     ))
  54
  55 (define (style-sheet-template-entry-compile entry size)
  56   (cons
  57    (string-append (caar entry)
  58                   " "
  59                   (number->string (- (cdar entry) size))
  60                   " ")
  61    (cdr entry)))
  62
  63 (define style-sheet-alist
  64   `(
  65     (paper11 . ,(map (lambda (x) (style-sheet-template-entry-compile x -3))
  66                      paper20-style-sheet-alist-template))
  67     (paper13 . ,(map (lambda (x) (style-sheet-template-entry-compile x -2))
  68                      paper20-style-sheet-alist-template))
  69     (paper16 . ,(map (lambda (x) (style-sheet-template-entry-compile x -1))
  70                      paper20-style-sheet-alist-template))
  71     (paper20 . ,(map (lambda (x) (style-sheet-template-entry-compile x 0))
  72                      paper20-style-sheet-alist-template))
  73     (paper23 . ,(map (lambda (x) (style-sheet-template-entry-compile x 1))
  74                      paper20-style-sheet-alist-template))
  75     (paper26 . ,(map (lambda (x) (style-sheet-template-entry-compile x 2))
  76                      paper20-style-sheet-alist-template))
  77      ))
  78
  79 (define (font-regexp-to-font-name paper regexp)
  80   (let ((style-sheet (cdr (assoc paper style-sheet-alist))))
  81     (let loop ((fonts style-sheet))
  82       (if (string-match regexp (caar fonts))
  83           (cdar fonts)
  84           (if (pair? (cdr fonts))
  85               (loop (cdr fonts))
  86               '())))))
  87
  88 (define (properties-to-font-name paper properties-alist)
  89   (let ((font-regexp (apply string-append
  90          (map (lambda (key)
  91                 (string-append
  92                  (let ((entry (assoc key properties-alist)))
  93                    (if entry (cdr entry) "[^ ]+"))
  94                  " "))
  95               '(font-series font-shape font-family font-name font-point font-size)))))
  96     (font-regexp-to-font-name paper font-regexp)))
  97
  98 (define markup-to-properties-alist
  99   '(
 100     (style . font-style)
 101     (series . font-series)
 102     (shape . font-shape)
 103     (family . font-family)
 104     (name . font-name)
 105     (size . font-size)
 106     (point . font-point)
 107     ))
 108
 109 (define markup-abbrev-to-properties-alist
 110   (append
 111    '(
 112      (rows . (align . 0))
 113      (lines . (align . 1))
 114      (roman . (font-family . "roman"))
 115      (music . (font-family . "music"))
 116      (bold . (font-series . "bold"))
 117      (italic . (font-shape . "italic"))
 118      (named . (lookup . name))
 119      (text . (lookup . value))
 120      (super . (font-size . -1)))
 121    (map (lambda (x) (cons (car x) (cons 'font-style (car x))))
 122         style-to-font-alist)))
 123
 124 (define (markup-to-properties markup)
 125   (if (pair? markup)
 126       (cons (cdr (assoc (car markup) markup-to-properties-alist)) (cdr markup))
 127       (cdr (assoc markup markup-abbrev-to-properties-alist))))
 128
 129 (define (style-to-font-name paper style)
 130   (let* ((entry (assoc style style-to-font-alist))
 131          (font (if entry (cdr entry) "* * * * * *"))
 132          (font-regexp
 133           (regexp-substitute/global #f "\\*" font 'pre "[^ ]+" 'post)))
 134     (font-regexp-to-font-name paper font-regexp)))
 135