X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-ps.scm;h=f5dcc38a59becef440da81678c497bd47d1abca7;hb=7dcae7597fae14ce5c4e2e7d50c2709d162b7332;hp=7a8612264bc66e5772c34ed1533b28f5b94698ab;hpb=c7c801a5653b8655fa4551336091da3d6ef41f1e;p=lilypond.git diff --git a/scm/output-ps.scm b/scm/output-ps.scm index 7a8612264b..f5dcc38a59 100644 --- a/scm/output-ps.scm +++ b/scm/output-ps.scm @@ -2,7 +2,7 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 1998--2005 Jan Nieuwenhuizen +;;;; (c) 1998--2006 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys ;;;; Note: currently misused as testbed for titles with markup, see @@ -18,26 +18,27 @@ ;; JUNK this -- see lily.scm: ly:all-output-backend-commands #:export (unknown - blank + bezier-sandwich + char circle - dot + comment + dashed-line dashed-slur - char - setcolor - resetcolor + dot + draw-line + embedded-ps named-glyph - dashed-line - zigzag-line - comment - repeat-slash + no-origin placebox - bezier-sandwich - embedded-ps + polygon + repeat-slash + resetcolor + resetrotation round-filled-box + setcolor + setrotation text - polygon - draw-line - no-origin)) + zigzag-line)) (use-modules (guile) @@ -48,24 +49,44 @@ (lily)) ;;; helper functions, not part of output interface +;;; + + (define (escape-parentheses s) (regexp-substitute/global #f "(^|[^\\])([\\(\\)])" s 'pre 1 "\\" 2 'post)) (define (ps-encoding text) (escape-parentheses text)) +(define (round2 num) + (/ (round (* 100 num)) 100)) + +(define (round4 num) + (/ (round (* 10000 num)) 10000)) + +(define (str4 num) + (format #f "~f" (round4 num))) + +(define (number-pair->string4 numpair) + (format #f "~f ~f" (round4 (car numpair)) (round4 (cdr numpair)))) + +(define (numbers->string4 numlist) + (string-join (map str4 numlist) " ")) + ;; FIXME: lily-def (define-public (ps-string-def prefix key val) - (string-append "/" prefix (symbol->string key) " (" - (escape-parentheses val) - ") def\n")) - + (format #f "/ ~a~a (~a) def\n" + prefix + (symbol->string key) + (escape-parentheses val))) (define (ps-number-def prefix key val) (let ((s (if (integer? val) (ly:number->string val) (ly:number->string (exact->inexact val))))) - (string-append "/" prefix (symbol->string key) " " s " def\n"))) + (format #f "/~a~a ~a def\n" + prefix + (symbol->string key) s))) ;;; @@ -74,116 +95,90 @@ ;; two beziers (define (bezier-sandwich lst thick) - (string-append - (string-join (map ly:number-pair->string lst) " ") - " " - (ly:number->string thick) - " draw_bezier_sandwich")) + (format #f "~a ~a draw_bezier_sandwich" + (string-join (map number-pair->string4 lst) " ") + (str4 thick))) (define (char font i) - (string-append - (ps-font-command font) " setfont " - "(\\" (ly:inexact->string i 8) ") show")) + (format #f "~a (\\~a) show" + (ps-font-command font) + (ly:inexact->string i 8))) (define (circle radius thick fill) - (format - "~a ~a ~a draw_circle" radius thick + (format #f + "~a ~f ~f draw_circle" (if fill - "true " - "false "))) - -(define (dashed-line thick on off dx dy) - (string-append - (ly:number->string dx) " " - (ly:number->string dy) " " - (ly:number->string thick) - " [ " - (ly:number->string on) " " - (ly:number->string off) - " ] 0 draw_dashed_line")) + "true" + "false") + (round4 radius) (round4 thick))) + +(define (dashed-line thick on off dx dy phase) + (format #f "~a ~a ~a [ ~a ~a ] ~a draw_dashed_line" + (str4 dx) + (str4 dy) + (str4 thick) + (str4 on) + (str4 off) + (str4 phase) + + )) ;; what the heck is this interface ? (define (dashed-slur thick on off l) - (string-append - (string-join (map ly:number-pair->string l) " ") - " " - (ly:number->string thick) - " [ " - (ly:number->string on) - " " - (ly:number->string off) - " ] 0 draw_dashed_slur")) + (format #f "~a ~a [ ~a ~a ] 0 draw_dashed_slur" + (let ((control-points (append (cddr l) (list (car l) (cadr l))))) + (string-join (map number-pair->string4 control-points) " ")) + (str4 thick) + (str4 on) + (str4 off))) (define (dot x y radius) - (string-append - " " - (ly:numbers->string - (list x y radius)) " draw_dot")) + (format #f " ~a draw_dot" + (numbers->string4 (list radius x y)))) (define (draw-line thick x1 y1 x2 y2) - (string-append - "1 setlinecap 1 setlinejoin " - (ly:number->string thick) " setlinewidth " - (ly:number->string x1) " " - (ly:number->string y1) " moveto " - (ly:number->string x2) " " - (ly:number->string y2) " lineto stroke")) + (format #f "~a ~a ~a ~a ~a draw_line" + (str4 (- x2 x1)) + (str4 (- y2 y1)) + (str4 x1) + (str4 y1) + (str4 thick))) (define (embedded-ps string) string) - -(define (glyph-string - postscript-font-name - size cid? - x-y-named-glyphs) - - (define (encoding-vector-hack glyphs) - - ;; GS fucks up with glyphs that are not in the - ;; encoding vector. - (define (inner j glyphs) - (if (or (null? glyphs) (> j 256)) - '() - (cons (format "dup ~a /~a put\n" - j (car glyphs)) - (inner (1+ j) (cdr glyphs))))) - - (format "256 array 0 1 255 { 1 index exch /.notdef put} for\n ~a -/EncHack reencode-font /EncHack findfont" - (apply string-append (inner 32 glyphs)))) - ;; END HACK. +(define (glyph-string postscript-font-name + size + cid? + w-x-y-named-glyphs) + + (define (glyph-spec w x y g) + (let ((prefix (if (string? g) "/" ""))) + (format #f "~f ~f ~a~a" + (round2 (+ w x)) + (round2 y) + prefix g))) - (format #f "gsave 1 output-scale div 1 output-scale div scale - /~a ~a ~a scalefont setfont\n~a grestore" - postscript-font-name + (format #f (if cid? - " /CIDFont findresource " - " findfont") - +"/~a /CIDFont findresource ~a output-scale div scalefont setfont +~a +~a print_glyphs" + +"/~a ~a output-scale div selectfont +~a +~a print_glyphs") + postscript-font-name size - (apply - string-append - (map (lambda (item) - (let* - ((x (car item)) - (y (cadr item)) - (g (caddr item)) - (prefix (if (string? g) "/" ""))) - - (if (and (= 0.0 x) - (= 0.0 y)) - (format #f " ~a~a glyphshow\n" prefix g) - (format #f " ~a ~a rmoveto ~a~a glyphshow\n" - x y - prefix - g)))) - x-y-named-glyphs)))) + (string-join (map (lambda (x) (apply glyph-spec x)) + (reverse w-x-y-named-glyphs)) "\n") + (length w-x-y-named-glyphs))) + (define (grob-cause offset grob) (let* ((cause (ly:grob-property grob 'cause)) - (music-origin (if (ly:music? cause) - (ly:music-property cause 'origin)))) + (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)) @@ -196,15 +191,18 @@ (if (and (< 0 (interval-length x-ext)) (< 0 (interval-length y-ext))) - (format "~a ~a ~a ~a (textedit://~a:~a:~a:~a) mark_URI\n" + (format #f "~$ ~$ ~$ ~$ (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. - (re-sub " " "%20" file) + ;;full escaping. + + ;; backslash is interpreted by GS. + (string-regexp-substitute "\\\\" "/" + (string-regexp-substitute " " "%20" file)) (cadr location) (caddr location) (cadddr location)) @@ -213,50 +211,72 @@ (define (lily-def key val) (let ((prefix "lilypondlayout")) (if (string=? - (substring key 0 (min (string-length prefix) (string-length key))) - prefix) - (string-append "/" key " {" val "} bind def\n") - (string-append "/" key " (" val ") def\n")))) + (substring key 0 (min (string-length prefix) (string-length key))) + prefix) + (format "/~a { ~a } bind def\n" key val) + (format "/~a (~a) def\n" key val)))) (define (named-glyph font glyph) - (string-append - (ps-font-command font) " setfont " - "/" glyph " glyphshow ")) + (format #f "~a /~a glyphshow " ;;Why is there a space at the end? + (ps-font-command font) + glyph)) (define (no-origin) "") (define (placebox x y s) - (string-append - (ly:number->string x) " " (ly:number->string y) " { " s " } place-box\n")) - -(define (polygon points blotdiameter filled?) - (string-append - (ly:numbers->string points) " " - (ly:number->string (/ (length points) 2)) " " - (ly:number->string blotdiameter) - (if filled? " true " " false ") - " draw_polygon")) - -(define (repeat-slash wid slope thick) - (string-append - (ly:numbers->string (list wid slope thick)) - " draw_repeat_slash")) + (format #f +"~a ~a moveto +~a\n" + (str4 x) + (str4 y) + s)) + +(define (polygon points blot-diameter filled?) + (format #f "~a ~a ~a ~a draw_polygon" + (if filled? "true" "false") + (numbers->string4 points) + (number->string (- (/ (length points) 2) 1)) + (str4 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))) + (format #f "~a draw_repeat_slash" + (numbers->string4 (list x-width width height))))) + + +(define (round-filled-box left right bottom top blotdiam) + (let* ((halfblot (/ blotdiam 2)) + (x (- halfblot left)) + (width (- right (+ halfblot x))) + (y (- halfblot bottom)) + (height (- top (+ halfblot y)))) + (format #f "~a draw_round_box" + (numbers->string4 + (list width height x y blotdiam))))) + +;; save current color on stack and set new color +(define (setcolor r g b) + (format #f "gsave ~a setrgbcolor\n" + (numbers->string4 (list r g b)))) ;; restore color from stack -(define (resetcolor) - (string-append "setrgbcolor\n")) +(define (resetcolor) "grestore \n") -(define (round-filled-box x y width height blotdiam) - (string-append - (ly:numbers->string - (list x y width height blotdiam)) " draw_round_box")) +;; rotation around given point +(define (setrotation ang x y) + (format "gsave ~a translate ~a rotate ~a translate\n" + (numbers->string4 (list x y)) + (number->string ang) + (numbers->string4 (list (* -1 x) (* -1 y))))) + +(define (resetrotation ang x y) + "grestore ") -;; save current color on stack and set new color -(define (setcolor r g b) - (string-append "currentrgbcolor " - (ly:numbers->string (list r g b)) - " setrgbcolor\n")) (define (text font s) ;; (ly:warning (_ "TEXT backend-command encountered in Pango backend")) @@ -264,11 +284,12 @@ (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) " setfont " + (ps-font-command font) " " (string-join (vector->list (vector-for-each @@ -283,7 +304,7 @@ "\n unknown\n") (define (url-link url x y) - (format "~a ~a ~a ~a (~a) mark_URI" + (format #f "~$ ~$ ~$ ~$ (~a) mark_URI" (car x) (car y) (cdr x) @@ -294,14 +315,40 @@ (ly:warning (_ "utf-8-string encountered in PS backend"))) - (define (zigzag-line centre? zzw zzh thick dx dy) - (string-append - (if centre? "true" "false") " " - (ly:number->string zzw) " " - (ly:number->string zzh) " " - (ly:number->string thick) " " - "0 0 " - (ly:number->string dx) " " - (ly:number->string dy) - " draw_zigzag_line")) + (format #f "~a ~a ~a ~a 0 0 ~a ~a draw_zigzag_line" + (if centre? "true" "false") + (str4 zzw) + (str4 zzh) + (str4 thick) + (str4 dx) + (str4 dy))) + + +(define (path thickness exps) + (define (convert-path-exps exps) + (if (pair? exps) + (let* + ((head (car exps)) + (rest (cdr exps)) + (arity + (cond + ((memq head '(rmoveto rlineto lineto moveto)) 2) + ((memq head '(rcurveto curveto)) 6) + (else 1))) + (args (take rest arity)) + ) + + ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here. + (cons (format "~a ~a " + (string-join (map (lambda (x) (format "~a " x)) args) " ") + head) + (convert-path-exps (drop rest arity)))) + '())) + + + (format + "1 setlinecap ~a setlinewidth\n~a stroke" + thickness + (string-join (convert-path-exps exps) " "))) +