scm/font.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2004--2009 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 factor)
 155   (for-each
 156    (lambda (x)
 157      (add-font node
 158                (list (cons 'font-encoding (car x))
 159                      (cons 'font-family family))
 160                (cons (* factor (cadr x))
 161                      (caddr x))))
 162    `((fetaDynamic ,(ly:pt 20.0) ,feta-alphabet-size-vector)
 163      (fetaNumber ,(ly:pt 20.0) ,feta-alphabet-size-vector)
 164      (fetaMusic ,(ly:pt 20.0)
 165                 #(
 166                   ,(delay (ly:system-font-load (string-append name "-11")))
 167                   ,(delay (ly:system-font-load (string-append name "-13")))
 168                   ,(delay (ly:system-font-load (string-append name "-14")))
 169                   ,(delay (ly:system-font-load (string-append name "-16")))
 170                   ,(delay (ly:system-font-load (string-append name "-18")))
 171                   ,(delay (ly:system-font-load (string-append name "-20")))
 172                   ,(delay (ly:system-font-load (string-append name "-23")))
 173                   ,(delay (ly:system-font-load (string-append name "-26")))
 174                   ))
 175      (fetaBraces ,(ly:pt 20.0)
 176                  #(,(delay (ly:system-font-load
 177                             ;;; TODO: rename aybabtu to emmentaler-brace
 178                             (if (string=? name "emmentaler")
 179                                 "aybabtu"
 180                                 (string-append name "-brace"))
 181                             )))))))
 182
 183 (define-public (add-pango-fonts node lily-family family factor)
 184   (define (add-node shape series)
 185     (add-font node
 186               `((font-family . ,lily-family)
 187                 (font-shape . ,shape)
 188                 (font-series . ,series)
 189                 (font-encoding . latin1) ;; ugh.
 190                 )
 191               `(,(ly:pt (* factor 11.0))
 192                 . #(,(cons
 193                      (ly:pt 12)
 194                      (ly:make-pango-description-string
 195                        `(((font-family . ,family)
 196                           (font-series . ,series)
 197                           (font-shape . ,shape)))
 198                        (ly:pt 12)))))))
 199
 200   (add-node 'upright 'normal)
 201   (add-node 'caps 'normal)
 202   (add-node 'upright 'bold)
 203   (add-node 'italic 'normal)
 204   (add-node 'italic 'bold))
 205
 206 (define-public (make-pango-font-tree roman-str sans-str typewrite-str factor)
 207   (let ((n (make-font-tree-node 'font-encoding 'fetaMusic)))
 208     (add-music-fonts n "emmentaler" 'feta factor)
 209 ;; Let's not do this [yet], see input/regression/gonville.ly
 210 ;;    (add-music-fonts n "gonville" 'gonville factor)
 211     (add-pango-fonts n 'roman roman-str factor)
 212     (add-pango-fonts n 'sans sans-str factor)
 213     (add-pango-fonts n 'typewriter typewrite-str factor)
 214     n))
 215
 216 (define-public (make-century-schoolbook-tree factor)
 217   (make-pango-font-tree
 218     "Century Schoolbook L,serif"
 219     "sans-serif" "monospace" factor))
 220
 221 (define-public all-text-font-encodings
 222   '(latin1))
 223
 224 (define-public all-music-font-encodings
 225   '(fetaBraces
 226     fetaDynamic
 227     fetaMusic
 228     fetaNumber))
 229
 230 (define-public (magstep s)
 231   (exp (* (/ s 6) (log 2))))
 232
 233 (define-public (magnification->font-size m)
 234   (* 6 (/ (log m) (log 2))))