scm/font.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2004--2010 Han-Wen Nienhuys <hanwen@xs4all.nl>
   4 ;;;;
   5 ;;;; LilyPond is free software: you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation, either version 3 of the License, or
   8 ;;;; (at your option) any later version.
   9 ;;;;
  10 ;;;; LilyPond is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 ;; TODO:
  19 ;;
  20 ;; lookup-font should be written in  C.
  21 ;;
  22
  23 ;; We have a tree, where each level of the tree is a qualifier
  24 ;; (eg. encoding, family, shape, series etc.)  this defines the levels
  25 ;; in the tree.  The first one is encoding, so we can directly select
  26 ;; between text or music in the first step of the selection.
  27 (define default-qualifier-order
  28   '(font-encoding font-family font-shape font-series))
  29
  30 (define-class <Font-tree-element>
  31   ())
  32
  33 (define-class <Font-tree-leaf> (<Font-tree-element>)
  34   (default-size #:init-keyword #:default-size)
  35   (size-vector  #:init-keyword #:size-vector))
  36
  37 (define-class <Font-tree-node> (<Font-tree-element>)
  38   (qualifier #:init-keyword #:qualifier  #:accessor font-qualifier)
  39   (default #:init-keyword #:default #:accessor font-default)
  40   (children #:init-keyword #:children #:accessor font-children))
  41
  42 (define (make-font-tree-leaf size size-font-vector)
  43   (make <Font-tree-leaf> #:default-size size #:size-vector size-font-vector))
  44
  45 (define (make-font-tree-node
  46          qualifier default)
  47   (make <Font-tree-node>
  48     #:qualifier qualifier
  49     #:default default
  50     #:children (make-hash-table 11)))
  51
  52 (define-method (display (leaf <Font-tree-leaf>) port)
  53   (map (lambda (x) (display x port))
  54        (list
  55         "#<Font-size-family:\n"
  56         (slot-ref leaf 'default-size)
  57         (slot-ref leaf 'size-vector)
  58         "#>"
  59         )))
  60
  61 (define-method (display (node <Font-tree-node>) port)
  62   (map
  63    (lambda (x)
  64      (display x port))
  65    (list
  66     "Font_node {\nqual: "
  67     (font-qualifier node)
  68     "(def: "
  69     (font-default node)
  70     ") {\n"))
  71   (for-each
  72    (lambda (x)
  73      (display "\n")
  74      (display (car x) port)
  75      (display "=" port)
  76      (display (cdr x) port))
  77    (hash-table->alist (font-children node)))
  78   (display "} }\n"))
  79
  80
  81 (define-method (add-font (node <Font-tree-node>) fprops size-family)
  82   (define (assoc-delete key alist)
  83     (assoc-remove! (list-copy alist) key))
  84
  85   (define (make-node fprops size-family)
  86     (if (null? fprops)
  87         (make-font-tree-leaf (car size-family) (cdr size-family))
  88         (let* ((qual (next-qualifier default-qualifier-order fprops)))
  89           (make-font-tree-node qual
  90                                (assoc-get qual fprops)))))
  91
  92   (define (next-qualifier order props)
  93     (cond
  94      ((and (null? props) (null? order))
  95       #f)
  96      ((null? props) (car order))
  97      ((null? order) (caar props))
  98      (else
  99       (if (assoc-get (car order) props)
 100           (car order)
 101           (next-qualifier (cdr order) props)))))
 102
 103   (let* ((q (font-qualifier node))
 104          (d (font-default node))
 105          (v (assoc-get q fprops d))
 106          (new-fprops (assoc-delete q fprops))
 107          (child (hashq-ref (slot-ref node 'children)
 108                            v #f)))
 109     (if (not child)
 110         (begin
 111           (set! child (make-node new-fprops size-family))
 112           (hashq-set! (slot-ref node 'children) v child)))
 113     (if (pair? new-fprops)
 114         (add-font child new-fprops size-family))))
 115
 116 (define-method (add-font (node <Font-tree-leaf>) fprops size-family)
 117   (throw "must add to node, not leaf"))
 118
 119 (define-method (g-lookup-font (node <Font-tree-node>) alist-chain)
 120   (let* ((qual (font-qualifier node))
 121          (def (font-default node))
 122          (val (chain-assoc-get qual alist-chain def))
 123          (desired-child (hashq-ref (font-children node) val)))
 124
 125     (if desired-child
 126         (g-lookup-font desired-child alist-chain)
 127         (g-lookup-font (hashq-ref (font-children node) def) alist-chain))))
 128
 129 (define-method (g-lookup-font (node <Font-tree-leaf>) alist-chain)
 130   node)
 131
 132 ;; two step call is handy for debugging.
 133 (define (lookup-font node alist-chain)
 134   (g-lookup-font node alist-chain))
 135
 136
 137 ;; Ugh.  Currently, we load the PFB Feta fonts for `fetaText' with
 138 ;; Pango.  This should be changed to load the Emmentaler fonts instead
 139 ;; (with Pango too), but then we need support for a `font-style'
 140 ;; property which isn't implemented yet.
 141 (define feta-alphabet-size-vector
 142   (list->vector
 143    (map (lambda (tup)
 144           (cons (ly:pt (cdr tup))
 145                 (format "emmentaler~a ~a"
 146                         (car tup)
 147                         (ly:pt (cdr tup)))))
 148         '((11 . 11.22)
 149           (13 . 12.60)
 150           (14 .  14.14)
 151           (16 . 15.87)
 152           (18 . 17.82)
 153           (20 . 20)
 154           (23 . 22.45)
 155           (26 . 25.20)))))
 156
 157 ;; Each size family is a vector of fonts, loaded with a delay.  The
 158 ;; vector should be sorted according to ascending design size.
 159 (define-public (add-music-fonts node name family design-size-list factor)
 160   "Setup music fonts.
 161
 162 Arguments:
 163  NODE the font tree to modify.
 164  NAME is the basename for the music font. NAME-DESIGNSIZE.otf should be the music font,
 165   NAME-brace.otf should have piano braces.
 166  DESIGN-SIZE-LIST is a list of numbers, used as suffix for font filenames
 167  FACTOR is size factor relative to default size that is being used.
 168   This is used to select the proper design size for the text fonts.
 169 "
 170   (for-each
 171    (lambda (x)
 172      (add-font node
 173                (list (cons 'font-encoding (car x))
 174                      (cons 'font-family family))
 175                (cons (* factor (cadr x))
 176                      (caddr x))))
 177    `((fetaText ,(ly:pt 20.0) ,feta-alphabet-size-vector)
 178      (fetaMusic ,(ly:pt 20.0)
 179                 ,(list->vector
 180                   (map (lambda (size)
 181                          (delay (ly:system-font-load (format "~a-~a" name size))))
 182                        design-size-list
 183                        )))
 184      (fetaBraces ,(ly:pt 20.0)
 185                  #(,(delay (ly:system-font-load
 186                             (format "~a-brace" name)))))
 187      )))
 188
 189 (define-public (add-pango-fonts node lily-family family factor)
 190   ;; Synchronized with the `text-font-size' variable in
 191   ;; layout-set-absolute-staff-size-in-module (see paper.scm).
 192   (define text-font-size (ly:pt (* factor 11.0)))
 193
 194   (define (add-node shape series)
 195     (add-font node
 196               `((font-family . ,lily-family)
 197                 (font-shape . ,shape)
 198                 (font-series . ,series)
 199                 (font-encoding . latin1) ;; ugh.
 200                 )
 201               `(,text-font-size
 202                 . #(,(cons
 203                      (ly:pt 12)
 204                      (ly:make-pango-description-string
 205                        `(((font-family . ,family)
 206                           (font-series . ,series)
 207                           (font-shape . ,shape)))
 208                        (ly:pt 12)))))))
 209
 210   (add-node 'upright 'normal)
 211   (add-node 'caps 'normal)
 212   (add-node 'upright 'bold)
 213   (add-node 'italic 'normal)
 214   (add-node 'italic 'bold))
 215
 216 (define-public (make-pango-font-tree roman-str sans-str typewrite-str factor)
 217   (let ((n (make-font-tree-node 'font-encoding 'fetaMusic)))
 218     (add-music-fonts n "emmentaler" 'feta '(11 13 14 16 18 20 23 26) factor)
 219     (add-pango-fonts n 'roman roman-str factor)
 220     (add-pango-fonts n 'sans sans-str factor)
 221     (add-pango-fonts n 'typewriter typewrite-str factor)
 222     n))
 223
 224 (define-public (make-century-schoolbook-tree factor)
 225   (make-pango-font-tree
 226     "Century Schoolbook L,serif"
 227     "sans-serif" "monospace" factor))
 228
 229 (define-public all-text-font-encodings
 230   '(latin1))
 231
 232 (define-public all-music-font-encodings
 233   '(fetaBraces
 234     fetaMusic
 235     fetaText))
 236
 237 (define-public (magstep s)
 238   (exp (* (/ s 6) (log 2))))
 239
 240 (define-public (magnification->font-size m)
 241   (* 6 (/ (log m) (log 2))))