X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-ps.scm;h=9abd2774e8e46d057ad8b96182af5eef0d55ade6;hb=24bdff1e3d1639f8e6ebfc9611f38ea2c13be262;hp=1a136ba772b2f14dbd6c843daeffcf842386245d;hpb=1d67b863ede194b915a99240ca82e2e67b9d3dcb;p=lilypond.git diff --git a/scm/output-ps.scm b/scm/output-ps.scm index 1a136ba772..9abd2774e8 100644 --- a/scm/output-ps.scm +++ b/scm/output-ps.scm @@ -1,9 +1,20 @@ -;;;; 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--2009 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 @@ -14,32 +25,7 @@ ;;;; * 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) @@ -116,6 +102,14 @@ (- x2 x1) (- y2 y1) x1 y1 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,8 +120,8 @@ (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 @@ -147,38 +141,39 @@ (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)))) + (if (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)) + "")) + "")) + "")) (define (named-glyph font glyph) (ly:format "~a /~a glyphshow " ;;Why is there a space at the end? @@ -188,10 +183,18 @@ (define (no-origin) "") -(define (placebox x y s) +(define (oval x-radius y-radius thick fill) (ly:format -"~4f ~4f moveto -~a\n" x y s)) + "~a ~4f ~4f ~4f draw_oval" + (if fill + "true" + "false") + x-radius y-radius thick)) + +(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" @@ -225,7 +228,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) @@ -264,16 +267,13 @@ "\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 (convert-path-exps exps) (if (pair? exps) @@ -284,6 +284,7 @@ (cond ((memq head '(rmoveto rlineto lineto moveto)) 2) ((memq head '(rcurveto curveto)) 6) + ((eq? head 'closepath) 0) (else 1))) (args (take rest arity)) ) @@ -298,7 +299,7 @@ (ly:format - "1 setlinecap ~a setlinewidth\n~l stroke" + "gsave currentpoint translate 1 setlinecap ~a setlinewidth\n~l stroke grestore" thickness - (convert-path-exps exps) )) + (convert-path-exps exps)))