X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fframework-ps.scm;h=b412ab3269412a5a4809a10ea855b4c0b1adba1d;hb=7b51a4f655755a864f7efe6818b175d5eba2b31f;hp=becf51d275784d4d90436e59bf80e52bbd3aad0b;hpb=1efdabf3b2349ea7fa3183dca5bba5104c347c36;p=lilypond.git diff --git a/scm/framework-ps.scm b/scm/framework-ps.scm index becf51d275..b412ab3269 100644 --- a/scm/framework-ps.scm +++ b/scm/framework-ps.scm @@ -1,8 +1,19 @@ -;;;; framework-ps.scm -- structure for PostScript output +;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; source file of the GNU LilyPond music typesetter +;;;; Copyright (C) 2004--2012 Han-Wen Nienhuys ;;;; -;;;; (c) 2004--2009 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 . (define-module (scm framework-ps)) @@ -37,37 +48,15 @@ "%" "_" name))) "m" (string-encode-integer (inexact->exact (round (* 1000 magnify))))))) -(define (define-fonts paper) - (define font-list (ly:paper-fonts paper)) +(define (ps-define-pango-pf pango-pf font-name scaling) + "") - (define (define-font command fontname scaling) - (string-append - "/" command - " { /" fontname - " " (ly:number->string scaling) " output-scale div selectfont }" - " bind def\n")) - - (define (font-load-command font) - (let* ((specced-font-name (ly:font-name font)) - (fontname (if specced-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)) - (designsize (ly:font-design-size font)) - (magnification (* (ly:font-magnification font))) - (ops (ly:output-def-lookup paper 'output-scale)) - (scaling (* ops magnification designsize))) - (if (equal? fontname "unknown") - (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))) - font-list)))) +(define (ps-define-font font font-name scaling) + (string-append + "/" (ps-font-command font) + " { /" font-name + " " (ly:number->string scaling) " output-scale div selectfont }" + " bind def\n")) ;; FIXME: duplicated in other output backends ;; FIXME: silly interface name @@ -101,7 +90,7 @@ (ly:outputter-dump-string outputter (string-append - (format "%%Page: ~a ~a\n" page-number page-number) + (format #f "%%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" @@ -123,7 +112,7 @@ (names (apply append (map extract-names fonts)))) (apply string-append (map (lambda (f) - (format + (format #f (if load-fonts? "%%DocumentSuppliedResources: font ~a\n" "%%DocumentNeededResources: font ~a\n") @@ -174,7 +163,7 @@ "%%EndComments\n")) (define (procset file-name) - (format + (format #f "%%BeginResource: procset (~a) 1 0 ~a %%EndResource @@ -182,7 +171,7 @@ file-name (cached-file-contents file-name))) (define (embed-document file-name) - (format "%%BeginDocument: ~a + (format #f "%%BeginDocument: ~a ~a %%EndDocument " @@ -191,7 +180,7 @@ (define (setup-variables paper) (string-append "\n" - (define-fonts paper) + (define-fonts paper ps-define-font ps-define-pango-pf) (output-variables paper))) (define (cff-font? font) @@ -201,10 +190,10 @@ (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)) + (format #f "/~a ~s StartData " font-set-name (string-length body)) body)) (header - (format + (format #f "%%BeginResource: font ~a %!PS-Adobe-3.0 Resource-FontSet %%DocumentNeededResources: ProcSet (FontSetInit) @@ -229,8 +218,7 @@ (define (internal-font? file-name) (or (string-startswith file-name "Emmentaler") (string-startswith file-name "emmentaler") - (string-startswith file-name "aybabtu") - (string-startswith file-name "Aybabtu"))) + )) (define (load-font-via-GS font-name-filename) (define (ps-load-file file-name) @@ -239,11 +227,11 @@ (begin (set! file-name (ly:string-substitute (ly:get-option 'datadir) "" file-name)) - (format + (format #f "lilypond-datadir (~a) concatstrings (r) file .loadfont\n" file-name)) - (format "(~a) (r) file .loadfont\n" file-name)) - (format "% cannot find font file: ~a\n" file-name))) + (format #f "(~a) (r) file .loadfont\n" file-name)) + (format #f "% cannot find font file: ~a\n" file-name))) (let* ((font (car font-name-filename)) (name (cadr font-name-filename)) @@ -255,7 +243,7 @@ (cond ((internal-font? file-name) (ps-load-file (ly:find-file - (format "~a.otf" file-name)))) + (format #f "~a.otf" file-name)))) ((string? bare-file-name) (ps-load-file file-name)) (else @@ -275,14 +263,16 @@ (dir-helper dir (cons e lst))))) (reverse (dir-helper (opendir dir-name) '()))) - (define (handle-mac-font name filename) + (define (handle-mac-font name file-name) (let* ((dir-name (tmpnam)) (files '()) (status 0) - (embed #f)) + (embed #f) + (cwd (getcwd))) (mkdir dir-name #o700) - (set! status (ly:system - (format "cd ~a && fondu -force '~a'" dir-name filename))) + (chdir dir-name) + (set! status (ly:system (list "fondu" "-force" file-name))) + (chdir cwd) (set! files (dir-listing dir-name)) (for-each (lambda (f) @@ -301,7 +291,7 @@ (begin (set! embed "% failed\n") (ly:warning (_ "cannot extract file matching ~a from ~a") - name filename))) + name file-name))) embed)) (define (font-file-as-ps-string name file-name font-index) @@ -389,6 +379,7 @@ (pfas (map font-loader font-names))) pfas)) + (display "%%BeginProlog\n" port) (format port @@ -408,8 +399,49 @@ (display "%%EndProlog\n" port) (display "%%BeginSetup\ninit-lilypond-parameters\n%%EndSetup\n\n" port)) +(define (ps-quote str) + (fold + (lambda (replacement-list result) + (string-join + (string-split + result + (car replacement-list)) + (cadr replacement-list))) + str + '((#\\ "\\\\") (#\( "\\(") (#\) "\\)")))) + +;;; Create DOCINFO pdfmark containing metadata +;;; header fields with pdf prefix override those without the prefix +(define (handle-metadata header port) + (define (metadata-encode val) + ;; First, call ly:encode-string-for-pdf to encode the string (latin1 or + ;; utf-16be), then escape all parentheses and backslashes + ;; FIXME guile-2.0: use (string->utf16 str 'big) instead + + (ps-quote (ly:encode-string-for-pdf val))) + (define (metadata-lookup-output overridevar fallbackvar field) + (let* ((overrideval (ly:modules-lookup (list header) overridevar)) + (fallbackval (ly:modules-lookup (list header) fallbackvar)) + (val (if overrideval overrideval fallbackval))) + (if val + (format port "/~a (~a)\n" field (metadata-encode (markup->string val (list header))))))) + (display "[ " port) + (metadata-lookup-output 'pdfcomposer 'composer "Author") + (format port "/Creator (LilyPond ~a)\n" (lilypond-version)) + (metadata-lookup-output 'pdftitle 'title "Title") + (metadata-lookup-output 'pdfsubject 'subject "Subject") + (metadata-lookup-output 'pdfkeywords 'keywords "Keywords") + (metadata-lookup-output 'pdfmodDate 'modDate "ModDate") + (metadata-lookup-output 'pdfsubtitle 'subtitle "Subtitle") + (metadata-lookup-output 'pdfcomposer 'composer "Composer") + (metadata-lookup-output 'pdfarranger 'arranger "Arranger") + (metadata-lookup-output 'pdfpoet 'poet "Poet") + (metadata-lookup-output 'pdfcopyright 'copyright "Copyright") + (display "/DOCINFO pdfmark\n\n" port)) + + (define-public (output-framework basename book scopes fields) - (let* ((filename (format "~a.ps" basename)) + (let* ((filename (format #f "~a.ps" basename)) (outputter (ly:make-paper-outputter ;; FIXME: better wrap open/open-file, ;; content-mangling is always bad. @@ -417,6 +449,7 @@ (open-file filename "wb") 'ps)) (paper (ly:paper-book-paper book)) + (header (ly:paper-book-header book)) (systems (ly:paper-book-systems book)) (page-stencils (map page-stencil (ly:paper-book-pages book))) (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t)) @@ -432,6 +465,8 @@ ;; don't do BeginDefaults PageMedia: A4 ;; not necessary and wrong (write-preamble paper #t port) + (if (module? header) + (handle-metadata header port)) (for-each (lambda (page) (set! page-number (1+ page-number)) @@ -472,9 +507,9 @@ (define-public (dump-stencil-as-EPS-with-bbox paper dump-me filename load-fonts bbox) - "Create an EPS file from stencil DUMP-ME to FILENAME. BBOX has -format (left-x, lower-y, right x, up-y). If LOAD-FONTS set, include -fonts inline." + "Create an EPS file from stencil @var{dump-me} to @var{filename}. +@var{bbox} has format @code{(left-x, lower-y, right-x, upper-y)}. If +@var{load-fonts} set, include fonts inline." (define (to-rounded-bp-box box) "Convert box to 1/72 inch with rounding to enlarge the box." (let* ((scale (ly:output-def-lookup paper 'output-scale)) @@ -496,7 +531,7 @@ fonts inline." ;; 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") + (open-file (format #f "~a.eps" filename) "wb") 'ps)) (port (ly:outputter-port outputter)) (rounded-bbox (to-rounded-bp-box bbox)) @@ -528,7 +563,7 @@ fonts inline." (bbox (list (car xext) (car yext) (cdr xext) (cdr yext))) (filename (if (< 0 count) - (format "~a-~a" basename count) + (format #f "~a-~a" basename count) basename))) (set! count (1+ count)) (dump-stencil-as-EPS-with-bbox paper @@ -537,10 +572,10 @@ fonts inline." (ly:get-option 'include-eps-fonts) bbox) (if do-pdf - (postscript->pdf 0 0 (format "~a.eps" filename))) + (postscript->pdf 0 0 (format #f "~a.eps" filename))) (if do-png (postscript->png (ly:get-option 'resolution) 0 0 - (format "~a.eps" filename))))) + (format #f "~a.eps" filename))))) extents-system-pairs))) (define-public (clip-system-EPSes basename paper-book) @@ -555,7 +590,7 @@ fonts inline." (for-each (lambda (region) (clip-systems-to-region - (format "~a-from-~a-to-~a-clip" + (format #f "~a-from-~a-to-~a-clip" basename (rhythmic-location->file-string (car region)) (rhythmic-location->file-string (cdr region))) @@ -580,65 +615,33 @@ fonts inline." #f systems) (for-each (lambda (system-list) - (clip-score-systems - (if (> count 0) - (format "~a-~a" basename count) - basename) - system-list)) + ;; filter out headers and top-level markup + (if (pair? system-list) + (clip-score-systems + (if (> count 0) + (format #f "~a-~a" basename count) + basename) + system-list))) score-system-list))) (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 'output-scale)) - (to-dump-systems '())) - ;; skip booktitles. - (if (and (not (ly:get-option 'include-book-title-preview)) - (pair? systems) - (ly:prob-property (car systems) 'is-book-title #f)) - (set! systems (cdr systems))) - (for-each - (lambda (sys) - (if (or (paper-system-title? sys) - (not (pair? to-dump-systems)) - (paper-system-title? (car to-dump-systems))) - (set! to-dump-systems (cons sys to-dump-systems)))) - systems) + (systems (relevant-book-systems book)) + (to-dump-systems (relevant-dump-systems systems))) (dump-stencil-as-EPS paper (stack-stencils Y DOWN 0.0 (map paper-system-stencil (reverse to-dump-systems))) - (format "~a.preview" basename) + (format #f "~a.preview" basename) #t) (postprocess-output book framework-ps-module - (format "~a.preview.eps" basename) + (format #f "~a.preview.eps" basename) (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 'output-scale)) - (titles (take-while paper-system-title? systems)) - (non-title (find (lambda (x) - (not (paper-system-title? x))) systems)) - (dump-me - (stack-stencils Y DOWN 0.0 - (map 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) - (ly:output-formats))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-public (convert-to-pdf book name) - (let* ((defs (ly:paper-book-paper book)) - (landscape (ly:output-def-lookup defs 'landscape)) +(define (output-width-height defs) + (let* ((landscape (ly:output-def-lookup defs 'landscape)) (output-scale (ly:output-def-lookup defs 'output-scale)) (convert (lambda (x) (* x output-scale (/ (ly:bp 1))))) @@ -646,23 +649,35 @@ fonts inline." (paper-height (convert (ly:output-def-lookup defs 'paper-height))) (w (if landscape paper-height paper-width)) (h (if landscape paper-width paper-height))) - (if (equal? (basename name ".ps") "-") - (ly:warning (_ "cannot convert to ~S" "PDF")) - (postscript->pdf w h name)))) + (cons w h))) + +(define (output-resolution defs) + (let ((defs-resolution (ly:output-def-lookup defs 'pngresolution))) + (if (number? defs-resolution) + defs-resolution + (ly:get-option 'resolution)))) + +(define (output-filename name) + (if (equal? (basename name ".ps") "-") + (string-append "./" name) + name)) + +(define-public (convert-to-pdf book name) + (let* ((defs (ly:paper-book-paper book)) + (width-height (output-width-height defs)) + (width (car width-height)) + (height (cdr width-height)) + (filename (output-filename name))) + (postscript->pdf width height filename))) (define-public (convert-to-png book name) (let* ((defs (ly:paper-book-paper book)) - (defs-resolution (ly:output-def-lookup defs 'pngresolution)) - (resolution (if (number? defs-resolution) - defs-resolution - (ly:get-option 'resolution))) - (paper-width (ly:output-def-lookup defs 'paper-width)) - (paper-height (ly:output-def-lookup defs 'paper-height)) - (output-scale (ly:output-def-lookup defs 'output-scale))) - (postscript->png resolution - (* paper-width output-scale (/ (ly:bp 1))) - (* paper-height output-scale (/ (ly:bp 1))) - name))) + (resolution (output-resolution defs)) + (width-height (output-width-height defs)) + (width (car width-height)) + (height (cdr width-height)) + (filename (output-filename name))) + (postscript->png resolution width height filename))) (define-public (convert-to-ps book name) #t)