X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fframework-ps.scm;fp=scm%2Fframework-ps.scm;h=7c44920d67ef05e33cd35d1720036a5bc7777a97;hb=941dff9d2a67080e0dd8474f1e70f0c72ace6424;hp=84f3a3bec82c553763ef3dd873627a6199bc3618;hpb=5a22d6233a39d3164e1ca043244794c268be4ad0;p=lilypond.git diff --git a/scm/framework-ps.scm b/scm/framework-ps.scm index 84f3a3bec8..7c44920d67 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--2011 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 @@ -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) @@ -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) @@ -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) @@ -345,7 +335,7 @@ (else (ly:warning (_ "do not know how to embed font ~s ~s ~s") name file-name font)))))) - + (define (load-fonts paper) (let* ((fonts (ly:paper-fonts paper)) @@ -389,6 +379,7 @@ (pfas (map font-loader font-names))) pfas)) + (display "%%BeginProlog\n" port) (format port @@ -408,6 +399,47 @@ (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)))))) + (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)) (outputter (ly:make-paper-outputter @@ -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)) @@ -509,7 +544,7 @@ fonts inline." (display "stroke grestore\n%%Trailer\n%%EOF\n" port) (ly:outputter-close outputter))) -(define (clip-systems-to-region basename paper systems region do-pdf) +(define (clip-systems-to-region basename paper systems region do-pdf do-png) (let* ((extents-system-pairs (filtered-map (lambda (paper-system) (let* ((x-ext (system-clipped-x-extent @@ -537,12 +572,17 @@ 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 "~a.eps" filename))) + (if do-png + (postscript->png (ly:get-option 'resolution) 0 0 + (format "~a.eps" filename))))) extents-system-pairs))) (define-public (clip-system-EPSes basename paper-book) (define do-pdf (member "pdf" (ly:output-formats))) + (define do-png + (member "png" (ly:output-formats))) (define (clip-score-systems basename systems) (let* ((layout (ly:grob-layout (paper-system-system-grob (car systems)))) @@ -555,7 +595,7 @@ fonts inline." (rhythmic-location->file-string (car region)) (rhythmic-location->file-string (cdr region))) layout systems region - do-pdf)) + do-pdf do-png)) regions))) ;; partition in system lists sharing their layout blocks @@ -577,30 +617,17 @@ fonts inline." (for-each (lambda (system-list) ;; filter out headers and top-level markup (if (pair? system-list) - (clip-score-systems - (if (> count 0) - (format "~a-~a" basename count) - basename) - system-list))) + (clip-score-systems + (if (> count 0) + (format "~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 @@ -611,31 +638,10 @@ fonts inline." (format "~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))))) @@ -643,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)