-;;;; 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 <hanwen@xs4all.nl>
;;;;
-;;;; (c) 2004--2008 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; 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 <http://www.gnu.org/licenses/>.
(define-module (scm framework-ps))
"%" "_" 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
(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)
(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)
(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)
(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))
(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
(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))))
(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
#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 "~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
(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)))))
(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 <stdout> 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)
projects / lilypond.git / blobdiff