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