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