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-abbrev-to-properties-alist
 102   (append
 103    '(
 104      (rows . ((align . 0)))
 105      (lines . ((align . 1)))
 106      (roman . ((font-family . "roman")))
 107      (music . ((font-family . "music")))
 108      (bold . ((font-series . "bold")))
 109      (italic . ((font-shape . "italic")))
 110      (named . ((lookup . name)))
 111      (super . ((raise . 1) (font-size . "-1")))
 112      (sub . ((raise . -1) (font-size . "-1")))
 113      (text . ((lookup . value)))
 114      )
 115    (map (lambda (x) (cons (car x) (cons 'font-style (car x))))
 116         style-to-font-alist)))
 117
 118 (define (markup-to-properties markup)
 119   ;;  (display "markup: `")
 120   ;;(display markup)
 121   ;;(display "'\n")
 122   (if (pair? markup)
 123       (list markup)
 124       (let ((entry (assoc markup markup-abbrev-to-properties-alist)))
 125         (if entry (cdr entry)
 126             (list (cons markup #t))))))
 127
 128 (define (style-to-font-name paper style)
 129   (let* ((entry (assoc style style-to-font-alist))
 130          (font (if entry (cdr entry) "* * * * * *"))
 131          (font-regexp
 132           (regexp-substitute/global #f "\\*" font 'pre "[^ ]+" 'post)))
 133     (font-regexp-to-font-name paper font-regexp)))
 134