X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fframework-ps.scm;h=fb00c1c05ff82275f9d243bad06e809b5e246244;hb=460749bd94a022bb11ecd3de38b078f4135711c1;hp=1fd59496918005682970d19ea34746b5d39ee26f;hpb=4eeca0046602a7083480496eee2fe5c3e185bdc3;p=lilypond.git diff --git a/scm/framework-ps.scm b/scm/framework-ps.scm index 1fd5949691..fb00c1c05f 100644 --- a/scm/framework-ps.scm +++ b/scm/framework-ps.scm @@ -2,10 +2,12 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2004 Han-Wen Nienhuys +;;;; (c) 2004--2005 Han-Wen Nienhuys (define-module (scm framework-ps)) +;;; this is still too big a mess. + (use-modules (ice-9 regex) (ice-9 string-fun) (ice-9 format) @@ -14,139 +16,73 @@ (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 . override-coding) - (let* ((name (ly:font-filename font)) - (magnify (ly:font-magnification font)) - (coding-alist (ly:font-encoding-alist font)) - (input-encoding (assoc-get 'input-name coding-alist)) - (font-encoding (assoc-get 'output-name coding-alist)) - (coding-command (if (null? override-coding) - (if (equal? input-encoding font-encoding) - #f font-encoding) - (car override-coding)))) - - ;; FIXME: now feta stuff has feta* input-encoding (again?) - ;;(format (current-error-port) "FONT: ~S, ~S\n" name font-encoding) - ;;(format (current-error-port) "INPUT: ~S\n" input-encoding) - (if (and coding-command - (or - (equal? (substring coding-command 0 4) "feta") - (equal? (substring coding-command 0 8) "parmesan") - - )) - (set! coding-command #f)) + +(define-public (ps-font-command font) + (let* ((name (munge-lily-font-name (ly:font-file-name font))) + (magnify (ly:font-magnification font))) (string-append - "magfont" (string-encode-integer (hashq name 1000000)) - "m" (string-encode-integer (inexact->exact (round (* 1000 magnify)))) - (if (not coding-command) "" (string-append "e" coding-command))))) + "magfont" + (string-regexp-substitute "[ /%]" "_" name) + "m" (string-encode-integer (inexact->exact (round (* 1000 magnify))))))) (define (tex-font? fontname) (or (equal? (substring fontname 0 2) "cm") (equal? (substring fontname 0 2) "ec"))) -(define (load-fonts bookpaper) - (let* ((fonts (ly:bookpaper-fonts bookpaper)) - (font-names (uniq-list (sort (map ly:font-filename fonts) stringpfa bpath)) - (else - (ly:warn "Can't find PFA font ~S" x) - "")))) - (filter string? font-names)))) - - (string-join pfas "\n"))) - -(define (define-fonts bookpaper) - (define font-list (ly:bookpaper-fonts bookpaper)) +(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")) - (define (reencode-font plain encoding command) - (let ((coding-vector (get-coding-command encoding))) - (string-append - plain " " coding-vector " /" command " reencode-font\n" - "/" command "{ /" command " findfont 1 scalefont } bind def\n"))) - - (define (guess-ps-fontname basename) - - "We do not have the FontName, try to guess is from basename." - (cond - (#t basename) - ((tex-font? basename) - ;; FIXME: we need proper Fontmap for the bluesky CM*, EC* fonts. - ;; Only the fonts that we trace in mf/ are in our own FontMap. - (string-append basename ".pfb")) - (else (string-append basename ".pfa")))) + (define (standard-tex-font? x) + (or (equal? (substring x 0 2) "ms") + (equal? (substring x 0 2) "cm"))) (define (font-load-command font) (let* ((specced-font-name (ly:font-name font)) (fontname (if specced-font-name - specced-font-name - (guess-ps-fontname (ly:font-filename font)))) - - (coding-alist (ly:font-encoding-alist font)) - (input-encoding (assoc-get 'input-name coding-alist)) - (font-encoding (assoc-get 'output-name coding-alist)) + (munge-lily-font-name specced-font-name) + (ly:font-file-name font))) (command (ps-font-command font)) + ;; FIXME -- see (ps-font-command ) - (plain (ps-font-command font #f)) + (plain (ps-font-command font)) (designsize (ly:font-design-size font)) (magnification (* (ly:font-magnification font))) - (ops (ly:output-def-lookup bookpaper 'outputscale)) + (ops (ly:output-def-lookup paper 'outputscale)) (scaling (* ops magnification designsize))) - (string-append - (define-font plain fontname scaling) - (if (or (equal? input-encoding font-encoding) - ;; guh - (equal? font-encoding "fetaBraces") - (equal? font-encoding "fetaNumber") - (equal? font-encoding "fetaMusic") - (equal? font-encoding "parmesanMusic")) - "" - (reencode-font plain input-encoding command))))) - - (define (font-load-encoding encoding) - (let ((filename (get-coding-filename encoding))) - (ly:gulp-file (ly:kpathsea-expand-path filename)))) - - (let* ((encoding-list (map (lambda (x) - (assoc-get 'input-name - (ly:font-encoding-alist x))) - font-list)) - (encodings (uniq-list (sort-list (filter string? encoding-list) - stringstring, mostly +(define (output-variables layout) + ;; FIXME: duplicates output-layout's scope-entry->string, mostly (define (value->string val) (cond ((string? val) (string-append "(" val ")")) @@ -157,126 +93,409 @@ (define (output-entry ps-key ly-key) (string-append "/" ps-key " " - (value->string (ly:output-def-lookup paper ly-key)) " def \n")) + (value->string (ly:output-def-lookup layout ly-key)) " def\n")) (string-append - "/lily-output-units " (number->string mm-to-bigpoint) " def %% milimeter \n" + "/lily-output-units " + (number->string mm-to-bigpoint) + " def %% millimeter\n" (output-entry "staff-line-thickness" 'linethickness) (output-entry "line-width" 'linewidth) - (output-entry "paper-size" 'papersize) + (output-entry "paper-size" 'papersizename) (output-entry "staff-height" 'staffheight) ;junkme. "/output-scale " - (number->string (ly:output-def-lookup paper 'outputscale)) - " lily-output-units mul def \n")) - -(define (dump-page outputter page page-number page-count) - (ly:outputter-dump-string outputter + (number->string (ly:output-def-lookup layout 'outputscale)) + " def\n" + (output-entry "page-height" 'vsize) + (output-entry "page-width" 'hsize))) + +(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" - "0 0 start-system { " + + "%%BeginPageSetup\n" + (if landscape? + "page-width output-scale lily-output-units mul mul 0 translate 90 rotate\n" + "") + "%%EndPageSetup\n" + + "start-page { " "set-ps-scale-to-lily-scale " "\n")) (ly:outputter-dump-stencil outputter page) (ly:outputter-dump-string outputter "} stop-system \nshowpage\n")) -(define (eps-header bookpaper bbox) +(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))))) + + (let* ((fonts (ly:paper-fonts paper)) + (names (apply append (map extract-names fonts)))) + + (apply string-append + (map (lambda (f) + (format + (if load-fonts? + "%%DocumentSuppliedResources: font ~a\n" + "%%DocumentNeededResources: font ~a\n") + f)) + (uniq-list (sort names stringstring bbox) " ") "\n" + "%%Creator: LilyPond\n" + "%%BoundingBox: " + (string-join (map ly:number->string bbox) " ") "\n" + "%%Orientation: " + (if (eq? (ly:output-def-lookup paper 'landscape) #t) + "Landscape\n" + "Portrait\n") + (supplies-or-needs paper load-fonts?) "%%EndComments\n")) -(define (page-header bookpaper page-count) +(define (page-header paper page-count load-fonts?) (string-append "%!PS-Adobe-3.0\n" - "%%Creator: creator time-stamp\n" + "%%Creator: LilyPond\n" "%%Pages: " (number->string page-count) "\n" "%%PageOrder: Ascend\n" - "%%DocumentPaperSizes: " (ly:output-def-lookup bookpaper 'papersize) "\n")) - -(define (preamble bookpaper) - (list - (output-variables bookpaper) - (ly:gulp-file "music-drawing-routines.ps") - (ly:gulp-file "lilyponddefs.ps") - (load-fonts bookpaper) - (define-fonts bookpaper))) - -(define-public (output-framework outputter book scopes fields basename) - (let* ((bookpaper (ly:paper-book-book-paper book)) - (pages (ly:paper-book-pages book)) - (page-number 0) - (page-count (length pages))) - (for-each - (lambda (x) - (ly:outputter-dump-string outputter x)) - (cons - (page-header bookpaper page-count) - (preamble bookpaper))) - - (for-each - (lambda (page) - (set! page-number (1+ page-number)) - (dump-page outputter page page-number page-count)) - pages) - (ly:outputter-dump-string outputter "%%Trailer\n%%EOF\n"))) - -(define-public (output-preview-framework outputter book scopes fields basename) - (let* ((bookpaper (ly:paper-book-book-paper book)) - (systems (ly:paper-book-lines book)) - (scale (ly:output-def-lookup bookpaper 'outputscale )) - (titles (take-while ly:paper-system-title? systems)) - (non-title (find (lambda (x) (not (ly:paper-system-title? x))) systems)) - (dump-me - (stack-stencils Y DOWN 0.0 - (map ly:paper-system-stencil - (append titles (list non-title))))) - (xext (ly:stencil-extent dump-me X)) - (yext (ly:stencil-extent dump-me Y)) - ) + "%%Orientation: " + (if (eq? (ly:output-def-lookup paper 'landscape) #t) + "Landscape\n" + "Portrait\n") + "%%DocumentPaperSizes: " + (ly:output-def-lookup paper 'papersizename) "\n" + (supplies-or-needs paper load-fonts?) + "%%EndComments\n")) + +(define (procset file-name) + (string-append + (format + "%%BeginResource: procset (~a) 1 0 +~a +%%EndResource +" + file-name (cached-file-contents file-name)))) + +(define (setup 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 "))) + (> (string-length cff-string) 0))) + +(define-public (ps-embed-cff body font-set-name version) + (let* ((binary-data + (string-append + (format "/~a ~s StartData " font-set-name (string-length body)) + body)) + + (header + (format + "%%BeginResource: font ~a +%!PS-Adobe-3.0 Resource-FontSet +%%DocumentNeededResources: ProcSet (FontSetInit) +%%Title: (FontSet/~a) +%%Version: ~s +%%EndComments +%%IncludeResource: ProcSet (FontSetInit) +%%BeginResource: FontSet (~a) +/FontSetInit /ProcSet findresource begin +%%BeginData: ~s Binary Bytes +" + font-set-name font-set-name version font-set-name + (string-length binary-data))) + (footer "\n%%EndData +%%EndResource +%%EOF +%%EndResource\n")) + + (string-append + header + binary-data + footer))) + + +(define (write-preamble paper load-fonts? port) + + (define (load-font-via-GS font-name-filename) + (define (ps-load-file name) + (format "(~a) (r) file .loadfont " name)) - (for-each - (lambda (x) - (ly:outputter-dump-string outputter x)) - (cons - (eps-header bookpaper - (map + (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) + (cond + ((string-match "([eE]mmentaler|[Aa]ybabtu)" file-name) + (ps-load-file (ly:find-file + (format "~a.pfa" (munge-lily-font-name file-name))))) + ((string? bare-file-name) + (ps-load-file (munge-lily-font-name file-name))) + (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 + (munge-lily-font-name 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)) + ((and bare-file-name (string-match "\\.ttf" bare-file-name)) + (ly:ttf->pfa bare-file-name)) + + ((string-match "([eE]mmentaler|[Aa]ybabtu)" file-name) + (cached-file-contents + (format "~a.pfa" (munge-lily-font-name file-name)))) + + ((and bare-file-name (string-match "\\.otf" bare-file-name)) + (ps-embed-cff (ly:otf->cff bare-file-name) name 0)) + + ((and bare-file-name (string-match "\\.ttf" bare-file-name)) + (ly:ttf->pfa bare-file-name)) + + ((and font (cff-font? font)) + (ps-embed-cff (ly:otf-font-table-data font "CFF ") + name + 0)) + (else + (ly:warning (_ "don't know how to embed ~S=~S") name file-name) + ""))))) + + (define (load-fonts paper) + (let* ((fonts (ly:paper-fonts paper)) + (all-font-names + (map + (lambda (font) + (cond + ((string? (ly:font-file-name font)) + (list (list + font + (ly:font-name font) + (ly:font-file-name font)))) + ((ly:pango-font? font) + (map + (lambda (name-psname-pair) + (list #f + (car name-psname-pair) + (cdr name-psname-pair))) + (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)))) - (list (car xext) (car yext) - (cdr xext) (cdr yext)))) - (preamble bookpaper))) + (round (* x scale mm-to-bigpoint)))) mmbox))) + (list (car box) (cadr box) + (max (1+ (car box)) (caddr box)) + (max (1+ (cadr box)) (cadddr box))))) - (ly:outputter-dump-string outputter - (string-append "0 0 start-system { " - "set-ps-scale-to-lily-scale " - "\n")) - (ly:outputter-dump-stencil outputter dump-me) - (ly:outputter-dump-string outputter "} stop-system\n%%Trailer\n%%EOF\n"))) + (let* ((outputter (ly:make-paper-outputter (format "~a.eps" filename) "ps")) + (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)) + 0.0 x)) + (list (car xext) (car yext) + (cdr xext) (cdr yext)))) + (rounded-bbox (mm-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) + (ly:outputter-dump-stencil outputter dump-me) + (display "} stop-system\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 '()) + ) + + + + ;; 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))) + (set! systems (cdr systems))) + + (for-each + (lambda (sys) + (if (or + (ly:paper-system-title? sys) + (not (pair? to-dump-systems)) + (ly: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))) + (format "~a.preview" basename) + #t) + + (postprocess-output book framework-ps-module + (format "~a.preview.eps" basename) + (completize-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)) + (non-title (find (lambda (x) + (not (ly:paper-system-title? x))) systems)) + (dump-me + (stack-stencils Y DOWN 0.0 + (map ly:paper-system-stencil + (append titles (list non-title)))))) + (output-scopes scopes fields basename) + (dump-stencil-as-EPS paper dump-me + (format "~a.preview" basename) + #t) + + (postprocess-output book framework-ps-module + (format "~a.preview.eps" basename) + (completize-formats (ly:output-formats))) + + )) + ) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-public (convert-to-pdf book name) - (let* - ((defs (ly:paper-book-book-paper book)) - (size (ly:output-def-lookup book 'papersize))) + (let* ((defs (ly:paper-book-paper book)) + (papersizename (ly:output-def-lookup defs 'papersizename))) - (postscript->pdf (if (string? size) size "a4") - name))) + (if (equal? (basename name ".ps") "-") + (ly:warning (_ "can't convert to ~S" "PDF")) + (postscript->pdf (if (string? papersizename) papersizename "a4") + name)))) (define-public (convert-to-png book name) - (let* - ((defs (ly:paper-book-book-paper book)) - (resolution (ly:output-def-lookup defs 'pngresolution))) - - (postscript->png (if (number? resolution) resolution 90) + (let* ((defs (ly:paper-book-paper book)) + (defs-resolution (ly:output-def-lookup defs 'pngresolution)) + (resolution (if (number? defs-resolution) + defs-resolution + (cdr (assoc 'resolution + (ly:get-option 'command-line-settings))))) + (papersizename (ly:output-def-lookup defs 'papersizename))) + + (postscript->png resolution + (if (string? papersizename) + papersizename "a4") + name))) (define-public (convert-to-dvi book name) - (ly:warn "Can not generate DVI via the postscript back-end")) + (ly:warning (_ "can't generate ~S using the postscript back-end") "DVI")) (define-public (convert-to-tex book name) - (ly:warn "Can not generate TeX via the postscript back-end")) + (ly:warning (_ "can't generate ~S using the postscript back-end") "TeX")) (define-public (convert-to-ps book name) #t) -