X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-ps.scm;h=7c8a6ed39474fa5560002fb71f3744d4bf614047;hb=f374fa12dd5dd745d8e60afce450b3056c274906;hp=5cedc80a05d36bdebc8f333f134632a7cc2439d2;hpb=88ee66d5dd83870dad27267781b3d84386264beb;p=lilypond.git diff --git a/scm/output-ps.scm b/scm/output-ps.scm index 5cedc80a05..7c8a6ed394 100644 --- a/scm/output-ps.scm +++ b/scm/output-ps.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; Copyright (C) 1998--2010 Jan Nieuwenhuizen +;;;; Copyright (C) 1998--2012 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify @@ -18,7 +18,7 @@ ;;;; Note: currently misused as testbed for titles with markup, see ;;;; input/test/title-markup.ly -;;;; +;;;; ;;;; TODO: ;;;; * %% Papersize in (header ...) ;;;; * text setting, kerning. @@ -29,6 +29,7 @@ (use-modules (guile) (ice-9 regex) + (ice-9 optargs) (srfi srfi-1) (srfi srfi-13) (scm framework-ps) @@ -44,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) @@ -76,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 @@ -85,23 +86,21 @@ 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" @@ -123,8 +122,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 @@ -144,8 +143,16 @@ (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) + (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) @@ -164,8 +171,8 @@ ;; Backslashes are not valid ;; file URI path separators. - (ly:string-substitute - "\\" "/" (ly:string-percent-encode file)) + (ly:string-percent-encode + (ly:string-substitute "\\" "/" file)) (cadr location) (caddr location) @@ -182,15 +189,7 @@ (define (no-origin) "") -(define (oval x-radius y-radius thick fill) - (ly:format - "~a ~4f ~4f ~4f draw_oval" - (if fill - "true" - "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) "")) @@ -202,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)) @@ -239,30 +228,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) @@ -273,13 +239,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) @@ -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 - "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")