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     (("medium upright math msam 10" . -2) . "msam10")
  54     (("medium upright math msam 10" . -1) . "msam10")
  55     (("medium upright math msam 10" . 0) . "msam10")
  56     ))
  57
  58 (define (style-sheet-template-entry-compile entry size)
  59   (cons
  60    (string-append (caar entry)
  61                   " "
  62                   (number->string (- (cdar entry) size))
  63                   " ")
  64    (cdr entry)))
  65
  66 (define style-sheet-alist
  67   `(
  68     (paper11 . ,(map (lambda (x) (style-sheet-template-entry-compile x -3))
  69                      paper20-style-sheet-alist-template))
  70     (paper13 . ,(map (lambda (x) (style-sheet-template-entry-compile x -2))
  71                      paper20-style-sheet-alist-template))
  72     (paper16 . ,(map (lambda (x) (style-sheet-template-entry-compile x -1))
  73                      paper20-style-sheet-alist-template))
  74     (paper20 . ,(map (lambda (x) (style-sheet-template-entry-compile x 0))
  75                      paper20-style-sheet-alist-template))
  76     (paper23 . ,(map (lambda (x) (style-sheet-template-entry-compile x 1))
  77                      paper20-style-sheet-alist-template))
  78     (paper26 . ,(map (lambda (x) (style-sheet-template-entry-compile x 2))
  79                      paper20-style-sheet-alist-template))
  80      ))
  81
  82 (define (font-regexp-to-font-name paper regexp)
  83   (let ((style-sheet (cdr (assoc paper style-sheet-alist))))
  84     (let loop ((fonts style-sheet))
  85       (if (string-match regexp (caar fonts))
  86           (cdar fonts)
  87           (if (pair? (cdr fonts))
  88               (loop (cdr fonts))
  89               '())))))
  90
  91 (define (properties-to-font-name paper properties-alist)
  92   (let ((font-regexp (apply string-append
  93          (map (lambda (key)
  94                 (string-append
  95                  (let ((entry (assoc key properties-alist)))
  96                    (if entry (cdr entry) "[^ ]+"))
  97                  " "))
  98               '(font-series font-shape font-family font-name font-point font-size)))))
  99     (font-regexp-to-font-name paper font-regexp)))
 100
 101 (define markup-to-properties-alist
 102   '(
 103     (style . font-style)
 104     (series . font-series)
 105     (shape . font-shape)
 106     (family . font-family)
 107     (name . font-name)
 108     (size . font-size)
 109     (point . font-point)
 110     (kern . kern)
 111     ))
 112
 113 (define markup-abbrev-to-properties-alist
 114   (append
 115    '(
 116      (rows . (align . 0))
 117      (lines . (align . 1))
 118      (roman . (font-family . "roman"))
 119      (music . (font-family . "music"))
 120      (bold . (font-series . "bold"))
 121      (italic . (font-shape . "italic"))
 122      (named . (lookup . name))
 123      (text . (lookup . value))
 124      ;; super needs some work
 125      (super . (font-size . "-1")))
 126    (map (lambda (x) (cons (car x) (cons 'font-style (car x))))
 127         style-to-font-alist)))
 128
 129 (define (markup-to-properties markup)
 130   (if (pair? markup)
 131       (cons (cdr (assoc (car markup) markup-to-properties-alist)) (cdr markup))
 132       (cdr (assoc markup markup-abbrev-to-properties-alist))))
 133
 134 (define (style-to-font-name paper style)
 135   (let* ((entry (assoc style style-to-font-alist))
 136          (font (if entry (cdr entry) "* * * * * *"))
 137          (font-regexp
 138           (regexp-substitute/global #f "\\*" font 'pre "[^ ]+" 'post)))
 139     (font-regexp-to-font-name paper font-regexp)))
 140