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-size font-points
  13 ;;
  14 (define style-sheet-alist
  15   '(
  16     (paper16 . (
  17                 ("medium upright music feta 0 16" . "feta16")
  18                 ("medium upright music feta -1 13" . "feta13")
  19                 ("medium upright music feta -2 11" . "feta11")
  20                 ("medium upright music feta 1 20" . "feta20")
  21                 ("medium upright music feta 2 23" . "feta23")
  22                 ("medium upright orator feta-nummer 0 8" . "feta-nummer8")
  23                 ("medium upright orator feta-nummer -4 4" . "feta-nummer4")
  24                 ("medium upright roman cmr 0 8" . "cmr8")
  25                 ("medium upright roman cmr 1 10" . "cmr10")
  26                 ("bold upright roman cmbx 0 8" . "cmbx8")
  27                 ("bold upright roman cmbx 1 10" . "cmbx10")
  28                 ("medium italic roman cmbx 0 8" . "cmbx8")
  29                 ("medium italic roman cmbx 1 10" . "cmbx10")
  30                 ))
  31     (paper20 . (
  32                 ("medium upright music feta 0 20" . "feta20")
  33                 ("medium upright music feta -1 16" . "feta16")
  34                 ("medium upright music feta -2 13" . "feta13")
  35                 ("medium upright music feta 1 23" . "feta23")
  36                 ("medium upright music feta 2 26" . "feta26")
  37                 ("medium upright orator feta-nummer 0 10" . "feta-nummer10")
  38                 ("medium upright orator feta-nummer -4 5" . "feta-nummer5")
  39                 ("medium upright roman cmr 0 10" . "cmr10")
  40                 ("medium upright roman cmr 1 12" . "cmr12")
  41                 ("bold upright roman cmbx 0 10" . "cmbx10")
  42                 ("bold upright roman cmbx 1 12" . "cmbx12")
  43                 ("medium italic roman cmbx 0 10" . "cmbx10")
  44                 ("medium italic roman cmbx 1 12" . "cmbx12")
  45                 ))
  46     ))
  47
  48 (define (get-font-name style properties-alist)
  49   (let ((font-regexp
  50          (let loop ((p '(font-series font-shape font-family font-name font-size font-points)) (s ""))
  51            (let* ((key (if (pair? p) (car p) p))
  52                   (entry (assoc key properties-alist))
  53                   (value (if entry (cdr entry) "[^ ]+")))
  54              (if (pair? (cdr p))
  55                  (loop (cdr p) (string-append s value " "))
  56                  (string-append (string-append s value))))))
  57         (style-sheet (cdr (assoc style style-sheet-alist))))
  58     ;;(display "regex: `")
  59     ;;(display font-regexp)
  60     ;;(display "'")
  61     ;;(newline)
  62     (let loop ((fonts style-sheet))
  63       ;;(display "font: `")
  64       ;;(display (caar fonts))
  65       ;;(display "' = ")
  66       ;;(display (cdar fonts))
  67       ;;(newline)
  68       (if (string-match font-regexp (caar fonts))
  69           (cdar fonts)
  70           (if (pair? (cdr fonts))
  71               (loop (cdr fonts))
  72               '())))))
  73
  74 (define markup-to-properties-alist
  75   '((series . font-series)
  76     (shape . font-shape)
  77     (family . font-family)
  78     (name . font-name)
  79     (size . font-size)
  80     (point . font-point)))
  81
  82 (define markup-abbrev-to-properties-alist
  83   '((rows . (align . 0))
  84     (lines . (align . 1))
  85     (roman . (font-family . "roman"))
  86     (music . (font-family . "music"))
  87     (bold . (font-series . "bold"))
  88     (italic . (font-shape . "italic"))))
  89
  90 (define (markup-to-properties markup)
  91   ;;(display "markup: ")
  92   ;;(display markup)
  93   ;;(newline)
  94   (if (pair? markup)
  95       (cons (cdr (assoc (car markup) markup-to-properties-alist)) (cdr markup))
  96       (cdr (assoc markup markup-abbrev-to-properties-alist))))
  97