scm/font.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2004--2015 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 family name brace 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{family} is the family name of the music font.
 160
 161 @item
 162 @var{name} is the basename for the music font.
 163 @file{@var{name}-<designsize>.otf} should be the music font,
 164
 165 @item
 166 @var{brace} is the basename for the brace font.
 167 @file{@var{brace}-brace.otf} should have piano braces.
 168
 169 @item
 170 @var{design-size-alist} is a list of @code{(rounded . designsize)}.
 171 @code{rounded} is a suffix for font filenames, while @code{designsize}
 172 should be the actual design size.  The latter is used for text fonts
 173 loaded through pango/@/fontconfig.
 174
 175 @item
 176 @var{factor} is a size factor relative to the default size that is being
 177 used.  This is used to select the proper design size for the text fonts.
 178 @end itemize"
 179   (for-each
 180    (lambda (x)
 181      (add-font node
 182                (list (cons 'font-encoding (car x))
 183                      (cons 'font-family family))
 184                (cons (* factor (cadr x))
 185                      (caddr x))))
 186
 187    `((fetaText ,(ly:pt 20.0)
 188                ,(list->vector
 189                  (map (lambda (tup)
 190                         (cons (ly:pt (cdr tup))
 191                               (format #f "~a-~a ~a"
 192                                       name
 193                                       (car tup)
 194                                       (ly:pt (cdr tup)))))
 195                       design-size-alist)))
 196      (fetaMusic ,(ly:pt 20.0)
 197                 ,(list->vector
 198                   (map (lambda (size-tup)
 199                          (delay (ly:system-font-load
 200                                  (format #f "~a-~a" name (car size-tup)))))
 201                        design-size-alist
 202                        )))
 203      (fetaBraces ,(ly:pt 20.0)
 204                  #(,(delay (ly:system-font-load
 205                             (format #f "~a-brace" brace)))))
 206      )))
 207
 208 (define-public (add-pango-fonts node lily-family family factor)
 209   ;; Synchronized with the `text-font-size' variable in
 210   ;; layout-set-absolute-staff-size-in-module (see paper.scm).
 211   (define text-font-size (ly:pt (* factor 11.0)))
 212
 213   (define (add-node shape series)
 214     (add-font node
 215               `((font-family . ,lily-family)
 216                 (font-shape . ,shape)
 217                 (font-series . ,series)
 218                 (font-encoding . latin1) ;; ugh.
 219                 )
 220               `(,text-font-size
 221                 . #(,(cons
 222                       (ly:pt 12)
 223                       (ly:make-pango-description-string
 224                        `(((font-family . ,family)
 225                           (font-series . ,series)
 226                           (font-shape . ,shape)))
 227                        (ly:pt 12)))))))
 228
 229   (add-node 'upright 'normal)
 230   (add-node 'caps 'normal)
 231   (add-node 'upright 'bold)
 232   (add-node 'italic 'normal)
 233   (add-node 'italic 'bold))
 234
 235 ; This function allows the user to change the specific fonts, leaving others
 236 ; to the default values. This way, "make-pango-font-tree"'s syntax doesn't
 237 ; have to change from the user's perspective.
 238 ;
 239 ; Usage:
 240 ;   \paper {
 241 ;     #(define fonts
 242 ;       (set-global-fonts
 243 ;        #:music "gonville"  ; (the main notation font)
 244 ;        #:roman "FreeSerif" ; (the main/serif text font)
 245 ;       ))
 246 ;   }
 247 ;
 248 ; Leaving out "#:brace", "#:sans", and "#:typewriter" leave them at
 249 ; "emmentaler", "sans-serif", and "monospace", respectively. All fonts are
 250 ; still accesible through the usual scheme symbols: 'feta, 'roman, 'sans, and
 251 ; 'typewriter.
 252 ;
 253 ; Note that 'LilyPond Serif', 'LilyPond Sans Serif' and 'Lilypond Monospace'
 254 ; are aliases that are defined in mf/00-lilypond-fonts.conf.in (source file)
 255 ; or fonts/00-lilypond-fonts.conf (installed file).
 256
 257 (define*-public (set-global-fonts #:key
 258   (music "emmentaler")
 259   (brace "emmentaler")
 260   (roman (if (eq? (ly:get-option 'backend) 'svg)
 261              "serif" "LilyPond Serif"))
 262   (sans (if (eq? (ly:get-option 'backend) 'svg)
 263             "sans-serif" "LilyPond Sans Serif"))
 264   (typewriter (if (eq? (ly:get-option 'backend) 'svg)
 265                   "monospace" "LilyPond Monospace"))
 266   (factor 1))
 267   (let ((n (make-font-tree-node 'font-encoding 'fetaMusic)))
 268     (add-music-fonts n 'feta music brace feta-design-size-mapping factor)
 269     (add-pango-fonts n 'roman roman factor)
 270     (add-pango-fonts n 'sans sans factor)
 271     (add-pango-fonts n 'typewriter typewriter factor)
 272     n))
 273
 274 (define-public (make-pango-font-tree roman-str sans-str typewrite-str factor)
 275   (let ((n (make-font-tree-node 'font-encoding 'fetaMusic)))
 276     (add-music-fonts n 'feta "emmentaler" "emmentaler" feta-design-size-mapping factor)
 277     (add-pango-fonts n 'roman roman-str factor)
 278     (add-pango-fonts n 'sans sans-str factor)
 279     (add-pango-fonts n 'typewriter typewrite-str factor)
 280     n))
 281
 282 (define-public (make-default-fonts-tree factor)
 283   (make-pango-font-tree
 284    (if (eq? (ly:get-option 'backend) 'svg) "serif" "LilyPond Serif")
 285    (if (eq? (ly:get-option 'backend) 'svg) "sans-serif" "LilyPond Sans Serif")
 286    (if (eq? (ly:get-option 'backend) 'svg) "monospace" "LilyPond Monospace")
 287    factor))
 288
 289 (define-public all-text-font-encodings
 290   '(latin1))
 291
 292 (define-public all-music-font-encodings
 293   '(fetaBraces
 294     fetaMusic
 295     fetaText))
 296
 297 (define-public (magstep s)
 298   (exp (* (/ s 6) (log 2))))
 299
 300 (define-public (magnification->font-size m)
 301   (* 6 (/ (log m) (log 2))))