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 ;; TODO - we could actually construct this by loading all OTFs and
 137 ;; inspecting their design size fields.
 138 (define-public feta-design-size-mapping
 139   '((11 . 11.22)
 140     (13 . 12.60)
 141     (14 . 14.14)
 142     (16 . 15.87)
 143     (18 . 17.82)
 144     (20 . 20)
 145     (23 . 22.45)
 146     (26 . 25.20)))
 147
 148 ;; Each size family is a vector of fonts, loaded with a delay.  The
 149 ;; vector should be sorted according to ascending design size.
 150 (define-public (add-music-fonts node name family design-size-alist factor)
 151   "Set up music fonts.
 152
 153 Arguments:
 154  NODE the font tree to modify.
 155  NAME is the basename for the music font. NAME-DESIGNSIZE.otf should be the music font,
 156   NAME-brace.otf should have piano braces.
 157  DESIGN-SIZE-ALIST is a list of (ROUNDED . DESIGN-SIZE).  ROUNDED is
 158    a suffix for font filenames, while DESIGN-SIZE should be the actual
 159    design size.  The latter is used for text fonts loaded through
 160    pango/fontconfig
 161  FACTOR is a size factor relative to the default size that is being used.
 162   This is used to select the proper design size for the text fonts.
 163 "
 164   (for-each
 165    (lambda (x)
 166      (add-font node
 167                (list (cons 'font-encoding (car x))
 168                      (cons 'font-family family))
 169                (cons (* factor (cadr x))
 170                      (caddr x))))
 171
 172    `((fetaText ,(ly:pt 20.0)
 173                ,(list->vector
 174                  (map (lambda (tup)
 175                         (cons (ly:pt (cdr tup))
 176                               (format "~a-~a ~a"
 177                                       name
 178                                       (car tup)
 179                                       (ly:pt (cdr tup)))))
 180                       design-size-alist)))
 181      (fetaMusic ,(ly:pt 20.0)
 182                 ,(list->vector
 183                   (map (lambda (size-tup)
 184                          (delay (ly:system-font-load
 185                                  (format "~a-~a" name (car size-tup)))))
 186                        design-size-alist
 187                        )))
 188      (fetaBraces ,(ly:pt 20.0)
 189                  #(,(delay (ly:system-font-load
 190                             (format "~a-brace" name)))))
 191      )))
 192
 193 (define-public (add-pango-fonts node lily-family family factor)
 194   ;; Synchronized with the `text-font-size' variable in
 195   ;; layout-set-absolute-staff-size-in-module (see paper.scm).
 196   (define text-font-size (ly:pt (* factor 11.0)))
 197
 198   (define (add-node shape series)
 199     (add-font node
 200               `((font-family . ,lily-family)
 201                 (font-shape . ,shape)
 202                 (font-series . ,series)
 203                 (font-encoding . latin1) ;; ugh.
 204                 )
 205               `(,text-font-size
 206                 . #(,(cons
 207                      (ly:pt 12)
 208                      (ly:make-pango-description-string
 209                        `(((font-family . ,family)
 210                           (font-series . ,series)
 211                           (font-shape . ,shape)))
 212                        (ly:pt 12)))))))
 213
 214   (add-node 'upright 'normal)
 215   (add-node 'caps 'normal)
 216   (add-node 'upright 'bold)
 217   (add-node 'italic 'normal)
 218   (add-node 'italic 'bold))
 219
 220 (define-public (make-pango-font-tree roman-str sans-str typewrite-str factor)
 221   (let ((n (make-font-tree-node 'font-encoding 'fetaMusic)))
 222     (add-music-fonts n "emmentaler" 'feta feta-design-size-mapping factor)
 223     (add-pango-fonts n 'roman roman-str factor)
 224     (add-pango-fonts n 'sans sans-str factor)
 225     (add-pango-fonts n 'typewriter typewrite-str factor)
 226     n))
 227
 228 (define-public (make-century-schoolbook-tree factor)
 229   (make-pango-font-tree
 230     "Century Schoolbook L,serif"
 231     "sans-serif" "monospace" factor))
 232
 233 (define-public all-text-font-encodings
 234   '(latin1))
 235
 236 (define-public all-music-font-encodings
 237   '(fetaBraces
 238     fetaMusic
 239     fetaText))
 240
 241 (define-public (magstep s)
 242   (exp (* (/ s 6) (log 2))))
 243
 244 (define-public (magnification->font-size m)
 245   (* 6 (/ (log m) (log 2))))