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 13" . -3) . "feta11")
  33     (("medium upright music feta 13" . -4) . "feta11")
  34     (("medium upright music feta 23" . 1) . "feta23")
  35     (("medium upright music feta 26" . 2) . "feta26")
  36     (("medium upright braces feta-braces 20" . 0) . "feta-braces20")
  37     (("bold italic dynamic feta 10" . 0) . "feta-din10")
  38     ;; Hmm
  39     (("medium upright number feta-nummer 13" . 3) . "feta-nummer13")
  40     (("medium upright number feta-nummer 13" . 2) . "feta-nummer13")
  41     (("medium upright number feta-nummer 12" . 1) . "feta-nummer12")
  42     (("medium upright number feta-nummer 10" . 0) . "feta-nummer10")
  43     (("medium upright number feta-nummer 8" . -1) . "feta-nummer8")
  44     (("medium upright number feta-nummer 6" . -2) . "feta-nummer6")
  45     (("medium upright number feta-nummer 5" . -3) . "feta-nummer5")
  46     (("medium upright number feta-nummer 4" . -4) . "feta-nummer4")
  47     (("medium upright number feta-nummer 3" . -5) . "feta-nummer3")
  48     (("medium upright roman cmr 8" . -1) . "cmr8" )
  49     (("medium upright roman cmr 10" . 0) . "cmr10")
  50     (("medium upright roman cmr 12" . 1) . "cmr12")
  51     (("bold upright roman cmbx 10" . 0) . "cmbx10")
  52     (("bold upright roman cmbx 12" . 1) . "cmbx12")
  53     (("medium italic roman cmbx 10" . 0) . "cmbx10")
  54     (("medium italic roman cmbx 12" . 1) . "cmbx12")
  55     (("medium upright math msam 10" . -2) . "msam10")
  56     (("medium upright math msam 10" . -1) . "msam10")
  57     (("medium upright math msam 10" . 0) . "msam10")
  58     ))
  59
  60 (define (style-sheet-template-entry-compile entry size)
  61   (cons
  62    (string-append (caar entry)
  63                   " "
  64                   (number->string (- (cdar entry) size))
  65                   " ")
  66    (cdr entry)))
  67
  68 (define style-sheet-alist
  69   `(
  70     (paper11 . ,(map (lambda (x) (style-sheet-template-entry-compile x -3))
  71                      paper20-style-sheet-alist-template))
  72     (paper13 . ,(map (lambda (x) (style-sheet-template-entry-compile x -2))
  73                      paper20-style-sheet-alist-template))
  74     (paper16 . ,(map (lambda (x) (style-sheet-template-entry-compile x -1))
  75                      paper20-style-sheet-alist-template))
  76     (paper20 . ,(map (lambda (x) (style-sheet-template-entry-compile x 0))
  77                      paper20-style-sheet-alist-template))
  78     (paper23 . ,(map (lambda (x) (style-sheet-template-entry-compile x 1))
  79                      paper20-style-sheet-alist-template))
  80     (paper26 . ,(map (lambda (x) (style-sheet-template-entry-compile x 2))
  81                      paper20-style-sheet-alist-template))
  82      ))
  83
  84 (define (font-regexp-to-font-name paper regexp)
  85   (let ((style-sheet (cdr (assoc paper style-sheet-alist))))
  86     (let loop ((fonts style-sheet))
  87       (if (string-match regexp (caar fonts))
  88           (cdar fonts)
  89           (if (pair? (cdr fonts))
  90               (loop (cdr fonts))
  91               '())))))
  92
  93 (define (properties-to-font-name paper properties-alist)
  94   (let ((font-regexp (apply string-append
  95          (map (lambda (key)
  96                 (string-append
  97                  (let ((entry (assoc key properties-alist)))
  98                    (if entry (cdr entry) "[^ ]+"))
  99                  " "))
 100               '(font-series font-shape font-family font-name font-point font-size)))))
 101     ;;(display "font-regexp: `")
 102     ;;(display font-regexp)
 103     ;;(display "'\n")
 104     (font-regexp-to-font-name paper font-regexp)))
 105
 106 (define markup-abbrev-to-properties-alist
 107   (append
 108    '(
 109      (rows . ((align . 0)))
 110      (lines . ((align . 1)))
 111      (roman . ((font-family . "roman")))
 112      (music . ((font-family . "music")))
 113      (bold . ((font-series . "bold")))
 114      (italic . ((font-shape . "italic")))
 115      (named . ((lookup . name)))
 116      (super . ((raise . 1) (font-size . "-1")))
 117      (sub . ((raise . -1) (font-size . "-1")))
 118      (text . ((lookup . value)))
 119      )
 120    (map (lambda (x) (cons (car x) (cons 'font-style (car x))))
 121         style-to-font-alist)))
 122
 123 (define (markup-to-properties markup)
 124   ;;(display "markup: `")
 125   ;;(display markup)
 126   ;;(display "'\n")
 127   (if (pair? markup)
 128       (list markup)
 129       (let ((entry (assoc markup markup-abbrev-to-properties-alist)))
 130         (if entry (cdr entry)
 131             (list (cons markup #t))))))
 132
 133 (define (style-to-font-name paper style)
 134   (let* ((entry (assoc style style-to-font-alist))
 135          (font (if entry (cdr entry) "* * * * * *"))
 136          (font-regexp
 137           (regexp-substitute/global #f "\\*" font 'pre "[^ ]+" 'post)))
 138     (font-regexp-to-font-name paper font-regexp)))
 139