X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-ps.scm;h=c83b613cbd1ceca68b2157886cb05fb0b5bfa393;hb=b551257a9d5d4bd1b57d32ac0cea4684260dfd83;hp=6b2e3cff6bc9e98c8ce6f942599a44bced56ea89;hpb=8cab78caa0db1ba14f2e52e4c1ddbb541ea0e5cb;p=lilypond.git diff --git a/scm/output-ps.scm b/scm/output-ps.scm index 6b2e3cff6b..c83b613cbd 100644 --- a/scm/output-ps.scm +++ b/scm/output-ps.scm @@ -1,50 +1,35 @@ -;;;; 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. ;;;; * document output-interface (define-module (scm output-ps) - #:re-export (quote) - - ;; JUNK this -- see lily.scm: ly:all-output-backend-commands - #:export (unknown - bezier-sandwich - char - circle - comment - dashed-line - dashed-slur - dot - draw-line - ellipse - embedded-ps - named-glyph - no-origin - oval - placebox - polygon - repeat-slash - resetcolor - resetrotation - round-filled-box - setcolor - setrotation - text - )) - + #:re-export (quote)) (use-modules (guile) (ice-9 regex) + (ice-9 optargs) (srfi srfi-1) (srfi srfi-13) (scm framework-ps) @@ -60,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 @@ -75,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)) @@ -118,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" @@ -136,11 +131,11 @@ (define (glyph-spec w x y g) (let ((prefix (if (string? g) "/" ""))) - (ly:format "~4f ~4f ~a~a" - (+ w x) y + (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 @@ -178,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)) @@ -207,10 +201,10 @@ "false") x-radius y-radius thick)) -(define (placebox x y s) - (ly:format -"~4f ~4f moveto -~a\n" x y s)) +(define (placebox x y s) + (if (not (string-null? s)) + (ly:format "~4f ~4f moveto ~a\n" x y s) + "")) (define (polygon points blot-diameter filled?) (ly:format "~a ~4l ~a ~4f draw_polygon" @@ -256,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) @@ -290,19 +261,27 @@ (cdr y) url)) -(define (utf-8-string pango-font-description string) - (ly:warning (_ "utf-8-string encountered in PS backend"))) - -(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) + ((eq? head 'closepath) 0) (else 1))) (args (take rest arity)) ) @@ -310,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 - "1 setlinecap ~a setlinewidth\n~l stroke" - 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")