From aac243bd9509b7fbba7d79bc12b3792b33f98e2a Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 2 Mar 2004 21:00:35 +0000 Subject: [PATCH] (define-fonts): Fix TeX font scaling. --- ChangeLog | 4 ++ input/test/title-markup.ly | 29 +++++++- scm/output-ps.scm | 132 +++++++++++++++++++------------------ 3 files changed, 100 insertions(+), 65 deletions(-) diff --git a/ChangeLog b/ChangeLog index 04bce60516..67d362d69d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2004-03-02 Jan Nieuwenhuizen + + * scm/output-ps.scm (define-fonts): Fix TeX font scaling. + 2004-03-02 Heikki Junes * vim/ftplugin/lilypond.vim: diff --git a/input/test/title-markup.ly b/input/test/title-markup.ly index 08122870c0..424e6eb417 100644 --- a/input/test/title-markup.ly +++ b/input/test/title-markup.ly @@ -22,6 +22,28 @@ texidoc = " %} +sizeTest = \markup { + \column < + { \normalsize "normalsize" + \hspace #10 + \smaller "smaller" + \hspace #10 + \smaller \smaller "smaller" + \hspace #10 + \smaller \smaller \smaller "smaller" + } + " " + { \normalsize "normalsize" + \hspace #10 + \bigger "bigger" + \hspace #10 + \bigger \bigger "bigger" + \hspace #10 + \bigger \bigger \bigger "bigger" + } + > +} + \header { texidoc = "Make titles using markup (WIP)." @@ -33,7 +55,7 @@ texidoc = " (font-series . medium) (font-style . roman) (font-shape . upright) - (font-size . 0)) + (font-size . 2)) title = "Title String" subtitle = "(and (the) subtitle)" @@ -50,6 +72,7 @@ texidoc = " " " \center < \center < { \normalsize \bold \subtitle } > + %" " \hspace #60 " " > " " " " @@ -58,12 +81,14 @@ texidoc = " " " { \left-align { \smaller \caps \piece } \right-align { \upright \poet } } + " " > } + foe = \sizeTest } \score { \context Staff \notes \relative c' { - c-\markup { \center < \roman \caps "foe" > } + c-\sizeTest % \markup { \center < \roman \caps "foe" > } } } diff --git a/scm/output-ps.scm b/scm/output-ps.scm index c1cb9d14c8..96238dcf4c 100644 --- a/scm/output-ps.scm +++ b/scm/output-ps.scm @@ -11,7 +11,6 @@ ;;;; TODO: ;;;; * UGR: SPACE character in CM* fonts ;;;; * text setting, kerning? -;;;; * font size and designsize ;;;; * linewidth ;;;; * font properties ;;;; * construction/customisation of title markup @@ -26,6 +25,7 @@ (use-modules (guile) (ice-9 regex) + (srfi srfi-13) (lily)) @@ -44,27 +44,6 @@ ;; WIP -- stencils from markup? values of output-scopes (define header-stencil #f) -(define lily-traced-cm-fonts - (map symbol->string - '(cmbx14 - cmbx17 - cmbxti12 - cmbxti14 - cmbxti6 - cmbxti7 - cmbxti8 - cmcsc12 - cmcsc7 - cmcsc8 - cmss5 - cmss6 - cmss7 - cmti5 - cmti6 - cmtt17 - cmtt5 - cmtt6 - cmtt7))) ;;; helper functions, not part of output interface (define (escape-parentheses s) @@ -86,6 +65,9 @@ (number->string (exact->inexact val))))) (string-append "/" prefix (symbol->string key) " " s " def\n"))) +(define (tex-font? fontname) + (equal? (substring fontname 0 2) "cm")) + ;;; Output-interface functions @@ -140,50 +122,70 @@ (define (define-fonts internal-external-name-mag-pairs) - (define (font-load-command name-mag command) - - ;; frobnicate NAME to jibe with external definitions. - (define (possibly-capitalize-font-name name) - (cond - ((and (equal? (substring name 0 2) "cm") - (not (member name lily-traced-cm-fonts))) - - ;; huh, how is this supposed to work? - ;;(string-upcase name) - - (string-append name ".pfb")) - - ((equal? (substring name 0 4) "feta") - (regexp-substitute/global #f "feta([a-z-]*)([0-9]+)" name 'pre "GNU-LilyPond-feta" 1 "-" 2 'post)) - (else name))) + (define (fontname->designsize fontname) + (let ((i (string-index fontname char-numeric?))) + (string->number (substring fontname i)))) + + ;; (define (font-load-command name-mag command) + (define (font-load-command lst) + (let* ((key-name-size (car lst)) + (value (cdr lst)) + (value-name-size (car value)) + (command (cdr value)) + (fontname (car value-name-size)) + (designsize (if (tex-font? fontname) + (/ 12 (fontname->designsize fontname)) + ;; This is about 12/20 :-) + (cdr key-name-size))) + (fontsize (cdr value-name-size)) + (scaling (* 12 (/ fontsize designsize))) + (scaling (/ fontsize (/ designsize 12)))) + + ;; frobnicate NAME to jibe with external definitions. + (define (possibly-mangle-fontname fontname) + (cond + ((tex-font? fontname) + ;; FIXME: we need proper Fontmap for CM fonts, like so: + ;; /CMR10 (cmr10.pfb); + ;; (string-upcase fontname) + (string-append fontname ".pfb")) + ((or (equal? (substring fontname 0 4) "feta") + (equal? (substring fontname 0 8) "parmesan")) + (regexp-substitute/global + #f "(feta|parmesan)([a-z-]*)([0-9]+)" + fontname 'pre "GNU-LilyPond-" 1 2 "-" 3 'post)) + (else fontname))) + (if + #f + (begin + (newline) + (format (current-error-port) "key-name-size ~S\n" key-name-size) + (format (current-error-port) "value ~S\n" value) + (format (current-error-port) "value-name-size ~S\n" value-name-size) + (format (current-error-port) "command ~S\n" command) + (format (current-error-port) "designsize ~S\n" designsize) + (format (current-error-port) "fontname ~S\n" fontname) + (format (current-error-port) "fontsize ~S\n" fontsize) + (format (current-error-port) "scaling ~S\n" scaling))) + + (string-append + "/" command + " { /" (possibly-mangle-fontname fontname) " findfont " + (ly:number->string scaling) + "output-scale div scalefont setfont } bind def \n"))) - (string-append - "/" command - " { /" - ;; Ugh, the Bluesky type1 fonts for computer modern use capitalized - ;; postscript font names. - (possibly-capitalize-font-name (car name-mag)) - " findfont " - "20 " (ly:number->string (cdr name-mag)) " mul " - "output-scale div scalefont setfont } bind def " - "\n")) - (define (ps-encoded-fontswitch name-mag-pair) (let* ((key (car name-mag-pair)) - (value (cdr name-mag-pair))) - (cons key - (cons value - (string-append "lilyfont" - (car value) - "-" - (number->string (cdr value))))))) - - (set! font-name-alist (map ps-encoded-fontswitch - internal-external-name-mag-pairs)) + (value (cdr name-mag-pair)) + (fontname (car value)) + (scaling (cdr value))) + (cons key (cons value + (string-append + "lilyfont" fontname "-" (number->string scaling)))))) - (apply string-append - (map (lambda (x) (font-load-command (car x) (cdr x))) - (map cdr font-name-alist)))) + (set! font-name-alist + (map ps-encoded-fontswitch internal-external-name-mag-pairs)) + (apply string-append (map font-load-command font-name-alist))) (define (define-origin file line col) "") @@ -284,7 +286,11 @@ (if header-stencil (let ((x-ext (ly:stencil-get-extent header-stencil Y)) (y-ext (ly:stencil-get-extent header-stencil X))) - (display (start-system (interval-length x-ext) (interval-length y-ext)) + ;;(display (start-system (interval-length x-ext) (interval-length y-ext)) + (display (start-system + ;; output-scale trouble? + (/ (interval-length x-ext) 2) + (/ (interval-length y-ext) 2)) port) (output-stencil port (ly:stencil-get-expr header-stencil) '(0 . 0)) (display (stop-system) port))) -- 2.39.5