X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fframework-ps.scm;h=65fa29194422afe5f2e4cc7a2fc66b0399919a30;hb=96836c61532a417f64d4ef3b2732db7dcb0f5737;hp=2418b1c854827d67bd01bb0aa7feabb442b31d26;hpb=85cd825c1e09a31ae016c078971d78d7ad047e44;p=lilypond.git diff --git a/scm/framework-ps.scm b/scm/framework-ps.scm index 2418b1c854..65fa291944 100644 --- a/scm/framework-ps.scm +++ b/scm/framework-ps.scm @@ -1,8 +1,8 @@ -;;;; framework-ps.scm -- +;;;; framework-ps.scm -- structure for PostScript output ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2004--2005 Han-Wen Nienhuys +;;;; (c) 2004--2006 Han-Wen Nienhuys (define-module (scm framework-ps)) @@ -12,21 +12,20 @@ (ice-9 string-fun) (ice-9 format) (guile) + (scm page) + (scm paper-system) (srfi srfi-1) (srfi srfi-13) (lily)) + (define framework-ps-module (current-module)) ;;(define pdebug stderr) (define (pdebug . rest) #f) -(define mm-to-bigpoint - (/ 72 25.4)) - - (define-public (ps-font-command font) - (let* ((name (munge-lily-font-name (ly:font-file-name font))) + (let* ((name (ly:font-file-name font)) (magnify (ly:font-magnification font))) (string-append @@ -39,13 +38,14 @@ (equal? (substring fontname 0 2) "cm") (equal? (substring fontname 0 2) "ec"))) - (define (define-fonts paper) (define font-list (ly:paper-fonts paper)) (define (define-font command fontname scaling) (string-append - "/" command " { /" fontname " findfont " - (ly:number->string scaling) " output-scale div scalefont } bind def\n")) + "/" command " { /" fontname " " (ly:number->string scaling) " output-scale div selectfont } bind def\n")) +; (string-append +; "/" command " { /" fontname " findfont " +; (ly:number->string scaling) " output-scale div scalefont } bind def\n")) (define (standard-tex-font? x) (or (equal? (substring x 0 2) "ms") @@ -54,7 +54,7 @@ (define (font-load-command font) (let* ((specced-font-name (ly:font-name font)) (fontname (if specced-font-name - (munge-lily-font-name specced-font-name) + specced-font-name (ly:font-file-name font))) (command (ps-font-command font)) @@ -62,7 +62,7 @@ (plain (ps-font-command font)) (designsize (ly:font-design-size font)) (magnification (* (ly:font-magnification font))) - (ops (ly:output-def-lookup paper 'outputscale)) + (ops (ly:output-def-lookup paper 'output-scale)) (scaling (* ops magnification designsize))) ;; Bluesky pfbs have UPCASE names (sigh.) @@ -73,7 +73,6 @@ (display (list font fontname))) (define-font plain fontname scaling))) - (apply string-append (map (lambda (x) (font-load-command x)) (filter (lambda (x) (not (ly:pango-font? x))) @@ -83,7 +82,7 @@ ;; FIXME: silly interface name (define (output-variables layout) ;; FIXME: duplicates output-layout's scope-entry->string, mostly - (define (value->string val) + (define (value->string val) (cond ((string? val) (string-append "(" val ")")) ((symbol? val) (symbol->string val)) @@ -97,46 +96,44 @@ (string-append "/lily-output-units " - (number->string mm-to-bigpoint) + (number->string (/ (ly:bp 1))) " def %% millimeter\n" - (output-entry "staff-line-thickness" 'linethickness) - (output-entry "line-width" 'linewidth) + (output-entry "staff-line-thickness" 'line-thickness) + (output-entry "line-width" 'line-width) (output-entry "paper-size" 'papersizename) - (output-entry "staff-height" 'staffheight) ;junkme. + (output-entry "staff-height" 'staff-height) ;junkme. "/output-scale " - (number->string (ly:output-def-lookup layout 'outputscale)) + (number->string (ly:output-def-lookup layout 'output-scale)) " def\n" - (output-entry "page-height" 'vsize) - (output-entry "page-width" 'hsize))) + (output-entry "page-height" 'paper-height) + (output-entry "page-width" 'paper-width))) (define (dump-page outputter page page-number page-count landscape?) (ly:outputter-dump-string outputter (string-append - "%%Page: " - (number->string page-number) " " (number->string page-count) "\n" - + (format "%%Page: ~a ~a\n" page-number page-number) "%%BeginPageSetup\n" (if landscape? "page-width output-scale lily-output-units mul mul 0 translate 90 rotate\n" "") "%%EndPageSetup\n" - - "start-page { " + + "gsave 0 paper-height translate " "set-ps-scale-to-lily-scale " "\n")) (ly:outputter-dump-stencil outputter page) - (ly:outputter-dump-string outputter "} stop-system \nshowpage\n")) + (ly:outputter-dump-string outputter "stroke grestore \nshowpage\n")) (define (supplies-or-needs paper load-fonts?) (define (extract-names font) (if (ly:pango-font? font) (map car (ly:pango-font-physical-fonts font)) - (list (munge-lily-font-name (ly:font-name font))))) - + (list (ly:font-name font)))) + (let* ((fonts (ly:paper-fonts paper)) (names (apply append (map extract-names fonts)))) - + (apply string-append (map (lambda (f) (format @@ -148,7 +145,9 @@ (define (eps-header paper bbox load-fonts?) (string-append "%!PS-Adobe-2.0 EPSF-2.0\n" - "%%Creator: LilyPond\n" + "%%Creator: LilyPond " + (lilypond-version) + "\n" "%%BoundingBox: " (string-join (map ly:number->string bbox) " ") "\n" "%%Orientation: " @@ -158,44 +157,66 @@ (supplies-or-needs paper load-fonts?) "%%EndComments\n")) -(define (page-header paper page-count load-fonts?) +(define (ps-document-media paper) + (let* ((w (/ (* + (ly:output-def-lookup paper 'output-scale) + (ly:output-def-lookup paper 'paper-width)) (ly:bp 1))) + (h (/ (* + (ly:output-def-lookup paper 'paper-height) + (ly:output-def-lookup paper 'output-scale)) + (ly:bp 1))) + (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t))) + (format "%%DocumentMedia: ~a ~$ ~$ ~a ~a ~a\n" + (ly:output-def-lookup paper 'papersizename) + (if landscape? h w) + (if landscape? w h) + 80 ;; weight + "()" ;; color + "()" ;; type + ))) + + +(define (file-header paper page-count load-fonts?) (string-append "%!PS-Adobe-3.0\n" - "%%Creator: LilyPond\n" + "%%Creator: LilyPond " + (lilypond-version) + "\n" + "%%Pages: " (number->string page-count) "\n" "%%PageOrder: Ascend\n" "%%Orientation: " (if (eq? (ly:output-def-lookup paper 'landscape) #t) "Landscape\n" "Portrait\n") - "%%DocumentPaperSizes: " - (ly:output-def-lookup paper 'papersizename) "\n" + (ps-document-media paper) (supplies-or-needs paper load-fonts?) "%%EndComments\n")) (define (procset file-name) - (string-append - (format + (format "%%BeginResource: procset (~a) 1 0 ~a %%EndResource " - file-name (cached-file-contents file-name)))) + file-name (cached-file-contents file-name))) + +(define (embed-document file-name) + (format "%%BeginDocument: ~a +~a +%%EndDocument +" + file-name (cached-file-contents file-name))) -(define (setup paper) +(define (setup-variables paper) (string-append "\n" - "%%BeginSetup\n" (define-fonts paper) (output-variables paper) - "%%EndSetup\n")) - -(define-public (munge-lily-font-name name) - (regexp-substitute/global #f "([eE]mmentaler|[aA]ybabtu)" - name 'pre "PFA" 1 'post)) + )) (define (cff-font? font) (let* - ((cff-string (ly:otf-font-table-data font "CFF "))) + ((cff-string (ly:otf-font-table-data font "CFF "))) (> (string-length cff-string) 0))) (define-public (ps-embed-cff body font-set-name version) @@ -221,7 +242,6 @@ (string-length binary-data))) (footer "\n%%EndData %%EndResource -%%EOF %%EndResource\n")) (string-append @@ -231,43 +251,133 @@ (define (write-preamble paper load-fonts? port) - - (define (load-font font-name-filename) + + (define (load-font-via-GS font-name-filename) + (define (ps-load-file name) + (format + (if (string? name) + "(~a) (r) file .loadfont\n" + "% can't find font file: ~a\n") + name)) + (let* ((font (car font-name-filename)) (name (cadr font-name-filename)) (file-name (caddr font-name-filename)) (bare-file-name (ly:find-file file-name))) - (cons - (munge-lily-font-name name) + (cons + name (cond - ((and bare-file-name (string-match "\\.pfa" bare-file-name)) - (cached-file-contents bare-file-name)) - ((and bare-file-name (string-match "\\.pfb" bare-file-name)) - (ly:pfb->pfa bare-file-name)) + ((string-match "^([eE]mmentaler|[Aa]ybabtu)" file-name) + (ps-load-file (ly:find-file + (format "~a.otf" file-name)))) + ((string? bare-file-name) + (ps-load-file file-name)) + (else + (ly:warning (_ "can't embed ~S=~S") name file-name) + ""))))) + + (define (dir-join a b) + (if (equal? a "") + b + (string-append a "/" b))) + + (define (dir-listing dir-name) + (define (dir-helper dir lst) + (let ((e (readdir dir))) + (if (eof-object? e) lst (dir-helper dir (cons e lst))))) + (reverse (dir-helper (opendir dir-name) '()))) + + (define (handle-mac-font name filename) + (let* + ((dir-name (tmpnam)) + (files '()) + (status 0) + (embed #f)) + + (mkdir dir-name #o700) + (set! status (ly:system + (format "cd ~a && fondu -force '~a'" dir-name filename))) + + (set! files (dir-listing dir-name)) + + (for-each + (lambda (f) + (let* + ((full-name (dir-join dir-name f))) + + (if (and (not embed) + (equal? 'regular (stat:type (stat full-name))) + (equal? name (ly:ttf-ps-name full-name))) + + (set! embed + (font-file-as-ps-string name full-name))) + + (if (or (equal? "." f) + (equal? ".." f)) + #t + (delete-file full-name)))) + + + files) + (rmdir dir-name) + + (if (not embed) + (begin + (set! embed "% failed \n") + (ly:warning (_ "can't extract file matching ~a from ~a") name filename))) + embed)) + + (define (font-file-as-ps-string name file-name) + (let* + ((downcase-file-name (string-downcase file-name))) - ((string-match "([eE]mmentaler|[Aa]ybabtu)" file-name) - (cached-file-contents - (format "~a.pfa" (munge-lily-font-name file-name)))) + (cond + ((and file-name (string-match "\\.pfa" downcase-file-name)) + (embed-document file-name)) + ((and file-name (string-match "\\.pfb" downcase-file-name)) + (ly:pfb->pfa file-name)) + ((and file-name (string-match "\\.ttf" downcase-file-name)) + (ly:ttf->pfa file-name)) + ((and file-name (string-match "\\.otf" downcase-file-name)) + (ps-embed-cff (ly:otf->cff file-name) name 0)) + (else + (ly:warning (_ "don't know how to embed ~S=~S") name file-name) + "")))) + + (define (load-font font-name-filename) + (let* ((font (car font-name-filename)) + (name (cadr font-name-filename)) + (file-name (caddr font-name-filename)) + (bare-file-name (ly:find-file file-name))) + + (cons + name + (cond + + ((and + (eq? PLATFORM 'darwin) + bare-file-name (string-match "\\.dfont" bare-file-name)) + (handle-mac-font name bare-file-name)) - ((and bare-file-name (string-match "\\.ttf" bare-file-name)) - (ly:ttf->pfa bare-file-name)) + ((and + (eq? PLATFORM 'darwin) + bare-file-name (= (stat:size (stat bare-file-name)) 0)) + (handle-mac-font name bare-file-name)) ((and font (cff-font? font)) (ps-embed-cff (ly:otf-font-table-data font "CFF ") name 0)) - (bare-file-name (cached-file-contents bare-file-name)) - (cff-file-name (cached-file-contents cff-file-name)) + + (bare-file-name (font-file-as-ps-string name bare-file-name)) (else - (ly:warning (_ "can't find CFF/PFA/PFB font ~S=~S" name file-name)) - (cons font-name ""))) - ))) + (ly:warning (_ "don't know how to embed font ~s ~s ~s") + name file-name font)))))) + - (define (load-fonts paper) (let* ((fonts (ly:paper-fonts paper)) - (all-font-names (map (lambda (font) @@ -283,19 +393,26 @@ (list #f (car name-psname-pair) (cdr name-psname-pair))) - (ly:pango-font-physical-fonts font))) + (ly:pango-font-physical-fonts font))) + (else (ly:font-sub-fonts font)))) - + fonts)) (font-names (uniq-list (sort (apply append all-font-names) (lambda (x y) (stringexact - (round (* x scale mm-to-bigpoint)))) mmbox))) - - (list (car box) (cadr box) + (if (or (nan? x) (inf? x)) + 0 + (inexact->exact + (round (/ (* x scale) (ly:bp 1)))))) mmbox))) + + (list (car box) + (cadr box) (max (1+ (car box)) (caddr box)) - (max (1+ (cadr box)) (cadddr box))))) + (max (1+ (cadr box)) (cadddr box)) + ))) + + (let* ((outputter (ly:make-paper-outputter + ;; FIXME: better wrap open/open-file, + ;; content-mangling is always bad. + ;; MINGW hack: need to have "b"inary for embedding CFFs + (open-file (format "~a.eps" filename) "wb") + "ps")) - (let* ((outputter (ly:make-paper-outputter (format "~a.eps" filename) "ps")) + (left-overshoot -3) (port (ly:outputter-port outputter)) (xext (ly:stencil-extent dump-me X)) (yext (ly:stencil-extent dump-me Y)) (bbox (map (lambda (x) - (if (or (nan? x) (inf? x)) + (if (or (nan? x) (inf? x) + ;; FIXME: huh? + (equal? (format #f "~S" x) "+#.#") + (equal? (format #f "~S" x) "-#.#")) 0.0 x)) - (list (car xext) (car yext) - (cdr xext) (cdr yext)))) - (rounded-bbox (mm-to-bp-box bbox)) + + ;; the left-overshoot is to make sure that + ;; bar numbers stick out of margin uniformly. + ;; + (list (min left-overshoot (car xext)) + (car yext) (cdr xext) (cdr yext)))) + (rounded-bbox (to-bp-box bbox)) (port (ly:outputter-port outputter)) (header (eps-header paper rounded-bbox load-fonts?))) (display header port) (write-preamble paper load-fonts? port) - (display "start-system { set-ps-scale-to-lily-scale \n" port) + (display "gsave set-ps-scale-to-lily-scale \n" port) (ly:outputter-dump-stencil outputter dump-me) - (display "} stop-system\n%%Trailer\n%%EOF\n" port) + (display "stroke grestore\n%%Trailer\n%%EOF\n" port) (ly:outputter-close outputter))) - (define-public (output-preview-framework basename book scopes fields) - (let* ((paper (ly:paper-book-paper book)) (systems (ly:paper-book-systems book)) - (scale (ly:output-def-lookup paper 'outputscale)) - (to-dump-systems '()) - ) + (scale (ly:output-def-lookup paper 'output-scale)) + (to-dump-systems '())) - - ;; skip booktitles. (if (and - (not - (cdr (assoc - 'preview-include-book-title - (ly:get-option 'command-line-settings) - ))) - (< 1 (length systems)) - (ly:paper-system-title? (list-ref systems 0)) - (ly:paper-system-title? (list-ref systems 1))) + (not (ly:get-option 'preview-include-book-title)) + (pair? systems) + (ly:prob-property (car systems) 'is-book-title #f)) + (set! systems (cdr systems))) - + (for-each (lambda (sys) (if (or - (ly:paper-system-title? sys) + (paper-system-title? sys) (not (pair? to-dump-systems)) - (ly:paper-system-title? (car to-dump-systems))) + (paper-system-title? (car to-dump-systems))) (set! to-dump-systems (cons sys to-dump-systems)))) systems) (dump-stencil-as-EPS paper (stack-stencils Y DOWN 0.0 - (map ly:paper-system-stencil (reverse to-dump-systems))) + (map paper-system-stencil (reverse to-dump-systems))) (format "~a.preview" basename) #t) (postprocess-output book framework-ps-module (format "~a.preview.eps" basename) - (completize-formats (cons "png" (ly:output-formats)))) - - )) + (cons "png" (ly:output-formats))))) + (if #f (define-public (output-preview-framework basename book scopes fields) - + (let* ((paper (ly:paper-book-paper book)) (systems (ly:paper-book-systems book)) - (scale (ly:output-def-lookup paper 'outputscale)) - (titles (take-while ly:paper-system-title? systems)) + (scale (ly:output-def-lookup paper 'output-scale)) + (titles (take-while paper-system-title? systems)) (non-title (find (lambda (x) - (not (ly:paper-system-title? x))) systems)) + (not (paper-system-title? x))) systems)) (dump-me (stack-stencils Y DOWN 0.0 - (map ly:paper-system-stencil + (map paper-system-stencil (append titles (list non-title)))))) (output-scopes scopes fields basename) (dump-stencil-as-EPS paper dump-me @@ -442,10 +572,7 @@ (postprocess-output book framework-ps-module (format "~a.preview.eps" basename) - (completize-formats (ly:output-formats))) - - )) - ) + (ly:output-formats))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-public (convert-to-pdf book name) @@ -462,14 +589,11 @@ (defs-resolution (ly:output-def-lookup defs 'pngresolution)) (resolution (if (number? defs-resolution) defs-resolution - (cdr (assoc 'resolution - (ly:get-option 'command-line-settings))))) + (ly:get-option 'resolution))) (papersizename (ly:output-def-lookup defs 'papersizename))) (postscript->png resolution - (if (string? papersizename) - papersizename "a4") - + (if (string? papersizename) papersizename "a4") name))) (define-public (convert-to-dvi book name) @@ -480,3 +604,13 @@ (define-public (convert-to-ps book name) #t) + +(define-public (output-classic-framework basename book scopes fields) + + (ly:error (_ "\nThe PostScript backend does not support the 'classic' +framework. Use the EPS backend instead, + + lilypond -b eps + +or remove the lilypond-book specific settings from the input. +")))