X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-ps.scm;h=7c8a6ed39474fa5560002fb71f3744d4bf614047;hb=32a34dcef0c0041c6d62677487a380b5c8b85712;hp=1a136ba772b2f14dbd6c843daeffcf842386245d;hpb=c5a3f0c024f4cb629811cff9eb04abff36e94138;p=lilypond.git diff --git a/scm/output-ps.scm b/scm/output-ps.scm index 1a136ba772..7c8a6ed394 100644 --- a/scm/output-ps.scm +++ b/scm/output-ps.scm @@ -1,48 +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--2006 Jan Nieuwenhuizen +;;;; Copyright (C) 1998--2012 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 - embedded-ps - named-glyph - no-origin - 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) @@ -58,25 +45,19 @@ (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 ;;; -;; two beziers -(define (bezier-sandwich lst thick) - (ly:format "~l ~4f draw_bezier_sandwich" - (map number-pair->string4 lst) - thick)) - (define (char font i) (ly:format "~a (\\~a) show" (ps-font-command font) @@ -90,6 +71,12 @@ "false") radius thick)) +(define (start-enclosing-id-node s) + "") + +(define (end-enclosing-id-node) + "") + (define (dashed-line thick on off dx dy phase) (ly:format "~4f ~4f ~4f [ ~4f ~4f ] ~4f draw_dashed_line" dx @@ -99,23 +86,29 @@ off phase)) -;; what the heck is this interface ? -(define (dashed-slur thick on off l) - (ly:format "~l ~4f [ ~4f ~4f ] 0 draw_dashed_slur" - (let ((control-points (append (cddr l) (list (car l) (cadr l))))) - (map number-pair->string4 control-points)) - thick - on - off)) - -(define (dot x y radius) - (ly:format " ~4l draw_dot" (list radius x y))) - (define (draw-line thick x1 y1 x2 y2) (ly:format "~4f ~4f ~4f ~4f ~4f draw_line" (- 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" + (if fill + "true" + "false") + x-radius y-radius thick)) + (define (embedded-ps string) string) @@ -126,11 +119,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 @@ -147,38 +140,46 @@ (define (grob-cause offset grob) - (let* ((cause (ly:grob-property grob 'cause)) - (music-origin (if (ly:stream-event? cause) - (ly:event-property cause 'origin)))) - (if (not (ly:input-location? music-origin)) - "" - (let* ((location (ly:input-file-line-char-column music-origin)) - (raw-file (car location)) - (file (if (is-absolute? raw-file) - raw-file - (string-append (ly-getcwd) "/" raw-file))) - (x-ext (ly:grob-extent grob grob X)) - (y-ext (ly:grob-extent grob grob Y))) - - (if (and (< 0 (interval-length x-ext)) - (< 0 (interval-length y-ext))) - (ly:format "~4f ~4f ~4f ~4f (textedit://~a:~a:~a:~a) mark_URI\n" - (+ (car offset) (car x-ext)) - (+ (cdr offset) (car y-ext)) - (+ (car offset) (cdr x-ext)) - (+ (cdr offset) (cdr y-ext)) - - ;; TODO - ;;full escaping. - - ;; backslash is interpreted by GS. - (ly:string-substitute "\\" "/" - (ly:string-substitute " " "%20" file)) - (cadr location) - (caddr location) - (cadddr location)) - ""))))) - + (if (ly:get-option 'point-and-click) + (let* ((cause (ly:grob-property grob 'cause)) + (music-origin (if (ly:stream-event? cause) + (ly:event-property cause 'origin))) + (point-and-click (ly:get-option 'point-and-click))) + (if (and + (ly:input-location? music-origin) + (cond ((boolean? point-and-click) point-and-click) + ((symbol? point-and-click) + (ly:in-event-class? cause point-and-click)) + (else (any (lambda (t) + (ly:in-event-class? cause t)) + point-and-click)))) + (let* ((location (ly:input-file-line-char-column music-origin)) + (raw-file (car location)) + (file (if (is-absolute? raw-file) + raw-file + (string-append (ly-getcwd) "/" raw-file))) + (x-ext (ly:grob-extent grob grob X)) + (y-ext (ly:grob-extent grob grob Y))) + + (if (and (< 0 (interval-length x-ext)) + (< 0 (interval-length y-ext))) + (ly:format "~4f ~4f ~4f ~4f (textedit://~a:~a:~a:~a) mark_URI\n" + (+ (car offset) (car x-ext)) + (+ (cdr offset) (car y-ext)) + (+ (car offset) (cdr x-ext)) + (+ (cdr offset) (cdr y-ext)) + + ;; Backslashes are not valid + ;; file URI path separators. + (ly:string-percent-encode + (ly:string-substitute "\\" "/" file)) + + (cadr location) + (caddr location) + (cadddr location)) + "")) + "")) + "")) (define (named-glyph font glyph) (ly:format "~a /~a glyphshow " ;;Why is there a space at the end? @@ -188,10 +189,10 @@ (define (no-origin) "") -(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" @@ -200,16 +201,6 @@ (- (/ (length points) 2) 1) blot-diameter)) -(define (repeat-slash width slope beam-thickness) - (define (euclidean-length x y) - (sqrt (+ (* x x) (* y y)))) - - (let ((x-width (euclidean-length beam-thickness (/ beam-thickness slope))) - (height (* width slope))) - (ly:format "~4l draw_repeat_slash" - (list x-width width height)))) - - (define (round-filled-box left right bottom top blotdiam) (let* ((halfblot (/ blotdiam 2)) (x (- halfblot left)) @@ -225,7 +216,7 @@ (list r g b))) ;; restore color from stack -(define (resetcolor) "grestore \n") +(define (resetcolor) "grestore\n") ;; rotation around given point (define (setrotation ang x y) @@ -237,53 +228,38 @@ (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) - (ly:format "~a ~a ~a ~a (~a) mark_URI" + (ly:format "~a ~a currentpoint vector_add ~a ~a currentpoint vector_add (~a) mark_URI" (car x) (car y) (cdr x) (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)) ) @@ -291,14 +267,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")