X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-ps.scm;h=9c2e6908e7eca1d968f89c89db3ec0b493336a72;hb=260073be07f49a5f6f3be8df2af52873843eec60;hp=33dbdbc9fd92475a82585324c08ec61860f5a23c;hpb=57be7394ffa2e7d7ba6d60548dba563f3409d472;p=lilypond.git diff --git a/scm/output-ps.scm b/scm/output-ps.scm index 33dbdbc9fd..9c2e6908e7 100644 --- a/scm/output-ps.scm +++ b/scm/output-ps.scm @@ -21,9 +21,7 @@ blank circle dot - white-dot beam - bracket dashed-slur char setcolor @@ -31,17 +29,13 @@ named-glyph dashed-line zigzag-line - ez-ball comment repeat-slash placebox bezier-sandwich - horizontal-line embedded-ps - filledbox round-filled-box text - white-text polygon draw-line no-origin)) @@ -54,15 +48,6 @@ (scm framework-ps) (lily)) - -;;(map export -;; (append (ly:all-stencil-expressions) (ly:all-output-backend-commands))) - -;; huh? -;;(write (ly:all-output-backend-commands)) -;;(write (ly:all-stencil-expressions)) - - ;;; helper functions, not part of output interface (define (escape-parentheses s) (regexp-substitute/global #f "(^|[^\\])([\\(\\)])" s 'pre 1 "\\" 2 'post)) @@ -101,21 +86,18 @@ (ly:number->string thick) " draw_bezier_sandwich")) -(define (bracket arch_angle arch_width arch_height height arch_thick thick) - (string-append - (ly:numbers->string - (list arch_angle arch_width arch_height height arch_thick thick)) - " draw_bracket")) - -(define (circle radius thick) - (format - "~a ~a draw_circle" radius thick)) - (define (char font i) (string-append (ps-font-command font) " setfont " "(\\" (ly:inexact->string i 8) ") show")) +(define (circle radius thick fill) + (format + "~a ~a ~a draw_circle" radius thick + (if fill + "true " + "false "))) + (define (dashed-line thick on off dx dy) (string-append (ly:number->string dx) " " @@ -156,73 +138,80 @@ (define (embedded-ps string) string) -;; FIXME. -(define (ez-ball ch letter-col ball-col) - (string-append - " (" ch ") " - (ly:numbers->string (list letter-col ball-col)) - ;; FIXME: barf - " /Helvetica-Bold " - " draw_ez_ball")) - -;; FIXME: use draw_round_box -(define (filledbox breapth width depth height) - (string-append (ly:numbers->string (list breapth width depth height)) - " draw_box")) (define (glyph-string postscript-font-name - size + 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. + (format #f "gsave 1 output-scale div 1 output-scale div scale - /~a findfont ~a scalefont setfont\n~a grestore" postscript-font-name size - (apply - string-append - (map (lambda (item) - (let - ((x (car item)) - (y (cadr item)) - (g (caddr item))) - - (if (and (= 0.0 x) - (= 0.0 y)) - (format #f " /~a glyphshow " g) - (format #f " ~a ~a rmoveto /~a glyphshow " - x y g)))) - x-y-named-glyphs)) - )) + /~a ~a ~a scalefont setfont\n~a grestore" + postscript-font-name + (if cid? + " /CIDFont findresource " + " findfont") + + 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)))) (define (grob-cause offset grob) (let* ((cause (ly:grob-property grob 'cause)) (music-origin (if (ly:music? cause) - (ly:music-property cause 'origin))) - (location (if (ly:input-location? music-origin) - (ly:input-file-line-column music-origin) - #f - )) - (file (if location (string-append (getcwd) "/" (car location)) - #f)) - (x-ext (ly:grob-extent grob grob X)) - (y-ext (ly:grob-extent grob grob Y)) - ) - - (if (and location - (< 0 (interval-length x-ext)) - (< 0 (interval-length y-ext))) - - (format "~a ~a ~a ~a (textedit://~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)) - file - (cadr location) - (caddr location)) - ""))) - -;; WTF is this in every backend? -(define (horizontal-line x1 x2 th) - (draw-line th x1 0 x2 0)) + (ly:music-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))) + (format "~a ~a ~a ~a (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)) + file + (cadr location) + (caddr location) + (cadddr location)) + ""))))) (define (lily-def key val) (let ((prefix "lilypondlayout")) @@ -244,11 +233,12 @@ (string-append (ly:number->string x) " " (ly:number->string y) " { " s " } place-box\n")) -(define (polygon points blotdiameter) +(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) @@ -306,19 +296,7 @@ (define (utf8-string pango-font-description string) (ly:warning (_ "utf8-string encountered in PS backend"))) -(define (white-dot x y radius) - (string-append - " " - (ly:numbers->string - (list x y radius)) " draw_white_dot")) - -(define (white-text scale s) - (let ((mystring (string-append - "(" s ") " (number->string scale) - " /Helvetica-Bold " - " draw_white_text"))) - mystring - )) + (define (zigzag-line centre? zzw zzh thick dx dy) (string-append