X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-ps.scm;h=c83b613cbd1ceca68b2157886cb05fb0b5bfa393;hb=6e624bc354e691c7a0b9035e6cd9bee4257fe101;hp=ee1da5308e3be0a49254d3f108288b8f6ba6cd79;hpb=794dcbdb52faf4292036cd1b0270a956cf4316a3;p=lilypond.git diff --git a/scm/output-ps.scm b/scm/output-ps.scm index ee1da5308e..c83b613cbd 100644 --- a/scm/output-ps.scm +++ b/scm/output-ps.scm @@ -1,13 +1,24 @@ -;;;; output-ps.scm -- implement Scheme output interface for PostScript +;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; source file of the GNU LilyPond music typesetter -;;;; -;;;; (c) 1998--2009 Jan Nieuwenhuizen +;;;; Copyright (C) 1998--2011 Jan Nieuwenhuizen ;;;; 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 . ;;;; Note: currently misused as testbed for titles with markup, see ;;;; input/test/title-markup.ly -;;;; +;;;; ;;;; TODO: ;;;; * %% Papersize in (header ...) ;;;; * text setting, kerning. @@ -18,6 +29,7 @@ (use-modules (guile) (ice-9 regex) + (ice-9 optargs) (srfi srfi-1) (srfi srfi-13) (scm framework-ps) @@ -33,14 +45,14 @@ (define (str4 num) (if (or (nan? num) (inf? num)) (begin - (ly:warning (_ "Found infinity or nan in output. Substituting 0.0")) + (ly:warning (_ "Found infinity or nan in output. Substituting 0.0")) (if (ly:get-option 'strict-infinity-checking) (exit 1)) "0.0") (ly:number->string num))) (define (number-pair->string4 numpair) - (ly:format "~4l" numpair)) + (ly:format "~4l" numpair)) ;;; ;;; Lily output interface, PostScript implementation --- cleanup and docme @@ -48,7 +60,7 @@ ;; two beziers (define (bezier-sandwich lst thick) - (ly:format "~l ~4f draw_bezier_sandwich" + (ly:format "~l ~4f draw_bezier_sandwich" (map number-pair->string4 lst) thick)) @@ -91,6 +103,16 @@ (- x2 x1) (- y2 y1) x1 y1 thick)) +(define (partial-ellipse x-radius y-radius start-angle end-angle thick connect fill) + (ly:format "~a ~a ~4f ~4f ~4f ~4f ~4f draw_partial_ellipse" + (if fill "true" "false") + (if connect "true" "false") + x-radius + y-radius + start-angle + end-angle + thick)) + (define (ellipse x-radius y-radius thick fill) (ly:format "~a ~4f ~4f ~4f draw_ellipse" @@ -112,8 +134,8 @@ (ly:format "~4f ~4f ~4f ~a~a" w x y prefix g))) - - (ly:format + + (ly:format (if cid? "/~a /CIDFont findresource ~a output-scale div scalefont setfont ~a @@ -151,12 +173,11 @@ (+ (car offset) (cdr x-ext)) (+ (cdr offset) (cdr y-ext)) - ;; TODO - ;;full escaping. + ;; Backslashes are not valid + ;; file URI path separators. + (ly:string-percent-encode + (ly:string-substitute "\\" "/" file)) - ;; backslash is interpreted by GS. - (ly:string-substitute "\\" "/" - (ly:string-substitute " " "%20" file)) (cadr location) (caddr location) (cadddr location)) @@ -180,7 +201,7 @@ "false") x-radius y-radius thick)) -(define (placebox x y s) +(define (placebox x y s) (if (not (string-null? s)) (ly:format "~4f ~4f moveto ~a\n" x y s) "")) @@ -229,30 +250,7 @@ (define (resetrotation ang x y) "grestore ") - -(define (text font s) - ;; (ly:warning (_ "TEXT backend-command encountered in Pango backend")) - ;; (ly:warning (_ "Arguments: ~a ~a"" font str)) - - (let* ((space-length (cdar (ly:text-dimension font " "))) - (space-move (string-append (number->string space-length) - ;; how much precision do we need here? - " 0.0 rmoveto ")) - (out-vec (decode-byte-string s))) - - (string-append - (ps-font-command font) " " - (string-join - (vector->list - (vector-for-each - - (lambda (sym) - (if (eq? sym 'space) - space-move - (string-append "/" (symbol->string sym) " glyphshow"))) - out-vec)))))) - -(define (unknown) +(define (unknown) "\n unknown\n") (define (url-link url x y) @@ -263,13 +261,23 @@ (cdr y) url)) -(define (path thickness exps) +(define (page-link page-no x y) + (if (number? page-no) + (ly:format "~a ~a currentpoint vector_add ~a ~a currentpoint vector_add ~a mark_page_link" + (car x) + (car y) + (cdr x) + (cdr y) + page-no) + "")) + +(define* (path thickness exps #:optional (cap 'round) (join 'round) (fill? #f)) (define (convert-path-exps exps) (if (pair? exps) (let* ((head (car exps)) (rest (cdr exps)) - (arity + (arity (cond ((memq head '(rmoveto rlineto lineto moveto)) 2) ((memq head '(rcurveto curveto)) 6) @@ -281,14 +289,34 @@ ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here. (cons (ly:format "~l ~a " - args + args head) (convert-path-exps (drop rest arity)))) '())) - - - (ly:format - "gsave currentpoint translate 1 setlinecap ~a setlinewidth\n~l stroke grestore" - thickness - (convert-path-exps exps))) - + + (let ((cap-numeric (case cap ((butt) 0) ((round) 1) ((square) 2) + (else (begin + (ly:warning (_ "unknown line-cap-style: ~S") + (symbol->string cap)) + 1)))) + (join-numeric (case join ((miter) 0) ((round) 1) ((bevel) 2) + (else (begin + (ly:warning (_ "unknown line-join-style: ~S") + (symbol->string join)) + 1))))) + (ly:format + "gsave currentpoint translate +~a setlinecap ~a setlinejoin ~a setlinewidth +~l gsave stroke grestore ~a grestore" + cap-numeric + join-numeric + thickness + (convert-path-exps exps) + (if fill? "fill" "")))) + +(define (setscale x y) + (ly:format "gsave ~4l scale\n" + (list x y))) + +(define (resetscale) + "grestore\n")