scm/font.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2004--2014 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   (for-each (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   (for-each
  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 @itemize
 155 @item
 156 @var{node} is the font tree to modify.
 157
 158 @item
 159 @var{name} is the basename for the music font.
 160 @file{@var{name}-<designsize>.otf} should be the music font,
 161 @file{@var{name}-brace.otf} should have piano braces.
 162
 163 @item
 164 @var{family} is the family name of the music font.
 165
 166 @item
 167 @var{design-size-alist} is a list of @code{(rounded . designsize)}.
 168 @code{rounded} is a suffix for font filenames, while @code{designsize}
 169 should be the actual design size.  The latter is used for text fonts
 170 loaded through pango/@/fontconfig.
 171
 172 @item
 173 @var{factor} is a size factor relative to the default size that is being
 174 used.  This is used to select the proper design size for the text fonts.
 175 @end itemize"
 176   (for-each
 177    (lambda (x)
 178      (add-font node
 179                (list (cons 'font-encoding (car x))
 180                      (cons 'font-family family))
 181                (cons (* factor (cadr x))
 182                      (caddr x))))
 183
 184    `((fetaText ,(ly:pt 20.0)
 185                ,(list->vector
 186                  (map (lambda (tup)
 187                         (cons (ly:pt (cdr tup))
 188                               (format #f "~a-~a ~a"
 189                                       name
 190                                       (car tup)
 191                                       (ly:pt (cdr tup)))))
 192                       design-size-alist)))
 193      (fetaMusic ,(ly:pt 20.0)
 194                 ,(list->vector
 195                   (map (lambda (size-tup)
 196                          (delay (ly:system-font-load
 197                                  (format #f "~a-~a" name (car size-tup)))))
 198                        design-size-alist
 199                        )))
 200      (fetaBraces ,(ly:pt 20.0)
 201                  #(,(delay (ly:system-font-load
 202                             (format #f "~a-brace" name)))))
 203      )))
 204
 205 (define-public (add-pango-fonts node lily-family family factor)
 206   ;; Synchronized with the `text-font-size' variable in
 207   ;; layout-set-absolute-staff-size-in-module (see paper.scm).
 208   (define text-font-size (ly:pt (* factor 11.0)))
 209
 210   (define (add-node shape series)
 211     (add-font node
 212               `((font-family . ,lily-family)
 213                 (font-shape . ,shape)
 214                 (font-series . ,series)
 215                 (font-encoding . latin1) ;; ugh.
 216                 )
 217               `(,text-font-size
 218                 . #(,(cons
 219                       (ly:pt 12)
 220                       (ly:make-pango-description-string
 221                        `(((font-family . ,family)
 222                           (font-series . ,series)
 223                           (font-shape . ,shape)))
 224                        (ly:pt 12)))))))
 225
 226   (add-node 'upright 'normal)
 227   (add-node 'caps 'normal)
 228   (add-node 'upright 'bold)
 229   (add-node 'italic 'normal)
 230   (add-node 'italic 'bold))
 231
 232 (define-public (make-pango-font-tree roman-str sans-str typewrite-str factor)
 233   (let ((n (make-font-tree-node 'font-encoding 'fetaMusic)))
 234     (add-music-fonts n "emmentaler" 'feta feta-design-size-mapping factor)
 235     (add-pango-fonts n 'roman roman-str factor)
 236     (add-pango-fonts n 'sans sans-str factor)
 237     (add-pango-fonts n 'typewriter typewrite-str factor)
 238     n))
 239
 240 (define-public (make-century-schoolbook-tree factor)
 241   (make-pango-font-tree
 242    "Century Schoolbook L"
 243    "sans-serif" "monospace" factor))
 244
 245 (define-public all-text-font-encodings
 246   '(latin1))
 247
 248 (define-public all-music-font-encodings
 249   '(fetaBraces
 250     fetaMusic
 251     fetaText))
 252
 253 (define-public (magstep s)
 254   (exp (* (/ s 6) (log 2))))
 255
 256 (define-public (magnification->font-size m)
 257   (* 6 (/ (log m) (log 2))))