X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Ffont.scm;h=ed0f1307560251cb92294c6b6d76929032892f86;hb=2005e201323314c8439d6aca062386c70c784294;hp=403cca53991118bc0ed777b0cb734f647abb6199;hpb=5a9cd72634e721d75ea49f8985a3b34adf8fe8ff;p=lilypond.git diff --git a/scm/font.scm b/scm/font.scm index 403cca5399..ed0f130756 100644 --- a/scm/font.scm +++ b/scm/font.scm @@ -1,134 +1,245 @@ -;;; -;;; font.scm -- implement Font stuff -;;; -;;; source file of the GNU LilyPond music typesetter -;;; -;;; (c) 2000 Jan Nieuwenhuizen -;;; - - -;; Corresponding properties: +;;;; This file is part of LilyPond, the GNU music typesetter. +;;;; +;;;; Copyright (C) 2004--2011 Han-Wen Nienhuys +;;;; +;;;; LilyPond is free software: you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation, either version 3 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; LilyPond is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with LilyPond. If not, see . + +;; TODO: ;; -;; font-series font-shape font-family font-name font-point font-size +;; lookup-font should be written in C. ;; -(define style-to-font-alist - '( - (finger . "* * number * * -4") - (volta . "* * number * * -3") - (timesig . "* * number * * 0") - (mark . "* * number * * 2") - (script . "* * roman * * -1") - (large . "* * roman * * 1") - (Large . "bold * roman * * 2") - (dynamic . "bold * dynamic * * 0") - )) - -(define paper20-style-sheet-alist-template - '( - (("medium upright music feta 20" . 0) . "feta20") - (("medium upright music feta 16" . -1) . "feta16") - (("medium upright music feta 13" . -2) . "feta13") - (("medium upright music feta 23" . 1) . "feta23") - (("medium upright music feta 26" . 2) . "feta26") - (("medium upright braces feta-braces 20" . 0) . "feta-braces20") - (("bold italic dynamic feta 10" . 0) . "feta-din10") - ;; Hmm - (("medium upright number feta-nummer 13" . 3) . "feta-nummer13") - (("medium upright number feta-nummer 13" . 2) . "feta-nummer13") - (("medium upright number feta-nummer 12" . 1) . "feta-nummer12") - (("medium upright number feta-nummer 10" . 0) . "feta-nummer10") - (("medium upright number feta-nummer 8" . -1) . "feta-nummer8") - (("medium upright number feta-nummer 6" . -2) . "feta-nummer6") - (("medium upright number feta-nummer 5" . -3) . "feta-nummer5") - (("medium upright number feta-nummer 4" . -4) . "feta-nummer4") - (("medium upright number feta-nummer 3" . -5) . "feta-nummer3") - (("medium upright roman cmr 8" . -1) . "cmr8" ) - (("medium upright roman cmr 10" . 0) . "cmr10") - (("medium upright roman cmr 12" . 1) . "cmr12") - (("bold upright roman cmbx 10" . 0) . "cmbx10") - (("bold upright roman cmbx 12" . 1) . "cmbx12") - (("medium italic roman cmbx 10" . 0) . "cmbx10") - (("medium italic roman cmbx 12" . 1) . "cmbx12") - )) - -(define (style-sheet-template-entry-compile entry size) - (cons - (string-append (caar entry) - " " - (number->string (- (cdar entry) size)) - " ") - (cdr entry))) +;; We have a tree, where each level of the tree is a qualifier +;; (eg. encoding, family, shape, series etc.) this defines the levels +;; in the tree. The first one is encoding, so we can directly select +;; between text or music in the first step of the selection. +(define default-qualifier-order + '(font-encoding font-family font-shape font-series)) + +(define-class + ()) + +(define-class () + (default-size #:init-keyword #:default-size) + (size-vector #:init-keyword #:size-vector)) + +(define-class () + (qualifier #:init-keyword #:qualifier #:accessor font-qualifier) + (default #:init-keyword #:default #:accessor font-default) + (children #:init-keyword #:children #:accessor font-children)) + +(define (make-font-tree-leaf size size-font-vector) + (make #:default-size size #:size-vector size-font-vector)) + +(define (make-font-tree-node + qualifier default) + (make + #:qualifier qualifier + #:default default + #:children (make-hash-table 11))) + +(define-method (display (leaf ) port) + (map (lambda (x) (display x port)) + (list + "#" + ))) + +(define-method (display (node ) port) + (map + (lambda (x) + (display x port)) + (list + "Font_node {\nqual: " + (font-qualifier node) + "(def: " + (font-default node) + ") {\n")) + (for-each + (lambda (x) + (display "\n") + (display (car x) port) + (display "=" port) + (display (cdr x) port)) + (hash-table->alist (font-children node))) + (display "} }\n")) + + +(define-method (add-font (node ) fprops size-family) + (define (assoc-delete key alist) + (assoc-remove! (list-copy alist) key)) + + (define (make-node fprops size-family) + (if (null? fprops) + (make-font-tree-leaf (car size-family) (cdr size-family)) + (let* ((qual (next-qualifier default-qualifier-order fprops))) + (make-font-tree-node qual + (assoc-get qual fprops))))) + + (define (next-qualifier order props) + (cond + ((and (null? props) (null? order)) + #f) + ((null? props) (car order)) + ((null? order) (caar props)) + (else + (if (assoc-get (car order) props) + (car order) + (next-qualifier (cdr order) props))))) + + (let* ((q (font-qualifier node)) + (d (font-default node)) + (v (assoc-get q fprops d)) + (new-fprops (assoc-delete q fprops)) + (child (hashq-ref (slot-ref node 'children) + v #f))) + (if (not child) + (begin + (set! child (make-node new-fprops size-family)) + (hashq-set! (slot-ref node 'children) v child))) + (if (pair? new-fprops) + (add-font child new-fprops size-family)))) + +(define-method (add-font (node ) fprops size-family) + (throw "must add to node, not leaf")) + +(define-method (g-lookup-font (node ) alist-chain) + (let* ((qual (font-qualifier node)) + (def (font-default node)) + (val (chain-assoc-get qual alist-chain def)) + (desired-child (hashq-ref (font-children node) val))) + + (if desired-child + (g-lookup-font desired-child alist-chain) + (g-lookup-font (hashq-ref (font-children node) def) alist-chain)))) + +(define-method (g-lookup-font (node ) alist-chain) + node) + +;; two step call is handy for debugging. +(define (lookup-font node alist-chain) + (g-lookup-font node alist-chain)) + +;; TODO - we could actually construct this by loading all OTFs and +;; inspecting their design size fields. +(define-public feta-design-size-mapping + '((11 . 11.22) + (13 . 12.60) + (14 . 14.14) + (16 . 15.87) + (18 . 17.82) + (20 . 20) + (23 . 22.45) + (26 . 25.20))) + +;; Each size family is a vector of fonts, loaded with a delay. The +;; vector should be sorted according to ascending design size. +(define-public (add-music-fonts node name family design-size-alist factor) + "Set up music fonts. + +Arguments: + NODE the font tree to modify. + NAME is the basename for the music font. NAME-DESIGNSIZE.otf should be the music font, + NAME-brace.otf should have piano braces. + DESIGN-SIZE-ALIST is a list of (ROUNDED . DESIGN-SIZE). ROUNDED is + a suffix for font filenames, while DESIGN-SIZE should be the actual + design size. The latter is used for text fonts loaded through + pango/fontconfig + FACTOR is a size factor relative to the default size that is being used. + This is used to select the proper design size for the text fonts. +" + (for-each + (lambda (x) + (add-font node + (list (cons 'font-encoding (car x)) + (cons 'font-family family)) + (cons (* factor (cadr x)) + (caddr x)))) -(define style-sheet-alist - `( - (paper11 . ,(map (lambda (x) (style-sheet-template-entry-compile x -3)) - paper20-style-sheet-alist-template)) - (paper13 . ,(map (lambda (x) (style-sheet-template-entry-compile x -2)) - paper20-style-sheet-alist-template)) - (paper16 . ,(map (lambda (x) (style-sheet-template-entry-compile x -1)) - paper20-style-sheet-alist-template)) - (paper20 . ,(map (lambda (x) (style-sheet-template-entry-compile x 0)) - paper20-style-sheet-alist-template)) - (paper23 . ,(map (lambda (x) (style-sheet-template-entry-compile x 1)) - paper20-style-sheet-alist-template)) - (paper26 . ,(map (lambda (x) (style-sheet-template-entry-compile x 2)) - paper20-style-sheet-alist-template)) - )) - -(define (font-regexp-to-font-name paper regexp) - (let ((style-sheet (cdr (assoc paper style-sheet-alist)))) - (let loop ((fonts style-sheet)) - (if (string-match regexp (caar fonts)) - (cdar fonts) - (if (pair? (cdr fonts)) - (loop (cdr fonts)) - '()))))) - -(define (properties-to-font-name paper properties-alist) - (let ((font-regexp (apply string-append - (map (lambda (key) - (string-append - (let ((entry (assoc key properties-alist))) - (if entry (cdr entry) "[^ ]+")) - " ")) - '(font-series font-shape font-family font-name font-point font-size))))) - (font-regexp-to-font-name paper font-regexp))) - -(define markup-to-properties-alist - '( - (style . font-style) - (series . font-series) - (shape . font-shape) - (family . font-family) - (name . font-name) - (size . font-size) - (point . font-point) - )) - -(define markup-abbrev-to-properties-alist - (append - '( - (rows . (align . 0)) - (lines . (align . 1)) - (roman . (font-family . "roman")) - (music . (font-family . "music")) - (bold . (font-series . "bold")) - (italic . (font-shape . "italic")) - (named . (lookup . name)) - (text . (lookup . value))) - (map (lambda (x) (cons (car x) (cons 'font-style (car x)))) - style-to-font-alist))) - -(define (markup-to-properties markup) - (if (pair? markup) - (cons (cdr (assoc (car markup) markup-to-properties-alist)) (cdr markup)) - (cdr (assoc markup markup-abbrev-to-properties-alist)))) - -(define (style-to-font-name paper style) - (let* ((entry (assoc style style-to-font-alist)) - (font (if entry (cdr entry) "* * * * * *")) - (font-regexp - (regexp-substitute/global #f "\\*" font 'pre "[^ ]+" 'post))) - (font-regexp-to-font-name paper font-regexp))) + `((fetaText ,(ly:pt 20.0) + ,(list->vector + (map (lambda (tup) + (cons (ly:pt (cdr tup)) + (format "~a-~a ~a" + name + (car tup) + (ly:pt (cdr tup))))) + design-size-alist))) + (fetaMusic ,(ly:pt 20.0) + ,(list->vector + (map (lambda (size-tup) + (delay (ly:system-font-load + (format "~a-~a" name (car size-tup))))) + design-size-alist + ))) + (fetaBraces ,(ly:pt 20.0) + #(,(delay (ly:system-font-load + (format "~a-brace" name))))) + ))) + +(define-public (add-pango-fonts node lily-family family factor) + ;; Synchronized with the `text-font-size' variable in + ;; layout-set-absolute-staff-size-in-module (see paper.scm). + (define text-font-size (ly:pt (* factor 11.0))) + + (define (add-node shape series) + (add-font node + `((font-family . ,lily-family) + (font-shape . ,shape) + (font-series . ,series) + (font-encoding . latin1) ;; ugh. + ) + `(,text-font-size + . #(,(cons + (ly:pt 12) + (ly:make-pango-description-string + `(((font-family . ,family) + (font-series . ,series) + (font-shape . ,shape))) + (ly:pt 12))))))) + + (add-node 'upright 'normal) + (add-node 'caps 'normal) + (add-node 'upright 'bold) + (add-node 'italic 'normal) + (add-node 'italic 'bold)) + +(define-public (make-pango-font-tree roman-str sans-str typewrite-str factor) + (let ((n (make-font-tree-node 'font-encoding 'fetaMusic))) + (add-music-fonts n "emmentaler" 'feta feta-design-size-mapping factor) + (add-pango-fonts n 'roman roman-str factor) + (add-pango-fonts n 'sans sans-str factor) + (add-pango-fonts n 'typewriter typewrite-str factor) + n)) + +(define-public (make-century-schoolbook-tree factor) + (make-pango-font-tree + "Century Schoolbook L,serif" + "sans-serif" "monospace" factor)) + +(define-public all-text-font-encodings + '(latin1)) + +(define-public all-music-font-encodings + '(fetaBraces + fetaMusic + fetaText)) + +(define-public (magstep s) + (exp (* (/ s 6) (log 2)))) +(define-public (magnification->font-size m) + (* 6 (/ (log m) (log 2))))