X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-ps.scm;h=f7d0ee5b44a5ba0890f3c5e686890498ef5da70d;hb=aed0295b202901dcd07b289f94ff258a06b547e7;hp=b31ac807a49d98437f2fa0b5ce0fb06a5c1c8cac;hpb=f94f6c172d1311d4216d605e1e72161915505c1c;p=lilypond.git diff --git a/scm/output-ps.scm b/scm/output-ps.scm index b31ac807a4..f7d0ee5b44 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 @@ -21,9 +21,6 @@ blank circle dot - white-dot - beam - bracket dashed-slur char setcolor @@ -31,17 +28,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 +47,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)) @@ -88,11 +72,6 @@ ;;; Lily output interface, PostScript implementation --- cleanup and docme ;;; -;;; Output-interface functions -(define (beam width slope thick blot) - (string-append - (ly:numbers->string (list slope width thick blot)) " draw_beam" )) - ;; two beziers (define (bezier-sandwich lst thick) (string-append @@ -101,24 +80,17 @@ (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 (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 (char font i) - (string-append - (ps-font-command font) " setfont " - "(\\" (ly:inexact->string i 8) ") show")) + "false "))) (define (dashed-line thick on off dx dy) (string-append @@ -158,42 +130,34 @@ (ly:number->string y2) " lineto stroke")) (define (embedded-ps string) + (display (list "len " (string-length string) "\n")) 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 - x-y-named-glyphs) - (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\n" g) - (format #f " ~a ~a rmoveto /~a glyphshow\n" - x y g)))) - x-y-named-glyphs)))) + size cid? + w-x-y-named-glyphs) + + (format #f "gsave + /~a ~a ~a output-scale div scalefont setfont\n~a grestore" + postscript-font-name + (if cid? + " /CIDFont findresource " + " findfont") + size + (apply + string-append + (map (lambda (item) + (let* + ((w (car item)) + (x (cadr item)) + (y (caddr item)) + (g (cadddr item)) + (prefix (if (string? g) "/" ""))) + + (format #f " gsave ~a~a glyphshow grestore ~a ~a rmoveto \n" prefix g (+ w x) y) + )) + w-x-y-named-glyphs)))) (define (grob-cause offset grob) (let* ((cause (ly:grob-property grob 'cause)) @@ -201,31 +165,30 @@ (ly:music-property cause 'origin)))) (if (not (ly:input-location? music-origin)) "" - (let* ((location (ly:input-file-line-column music-origin)) + (let* ((location (ly:input-file-line-char-column music-origin)) (raw-file (car location)) - (file (if (and (> (string-length raw-file) 0) - (eq? (string-ref raw-file 0) #\/)) + (file (if (is-absolute? raw-file) raw-file - (string-append (getcwd) "/" 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) mark_URI\n" - (+ (car offset) (car x-ext)) - (+ (cdr offset) (car y-ext)) - (+ (car offset) (cdr x-ext)) - (+ (cdr offset) (cdr y-ext)) - file + (format "~a ~a ~a ~a (textedit://~a:~a:~a:~a) mark_URI\n" + (ly:number->string (+ (car offset) (car x-ext))) + (ly:number->string (+ (cdr offset) (car y-ext))) + (ly:number->string (+ (car offset) (cdr x-ext))) + (ly:number->string (+ (cdr offset) (cdr y-ext))) + + ;; TODO + ;; full escaping. + (string-regexp-substitute " " "%20" file) (cadr location) - (caddr location)) + (caddr location) + (cadddr location)) ""))))) -;; WTF is this in every backend? -(define (horizontal-line x1 x2 th) - (draw-line th x1 0 x2 0)) - (define (lily-def key val) (let ((prefix "lilypondlayout")) (if (string=? @@ -243,14 +206,22 @@ "") (define (placebox x y s) - (string-append - (ly:number->string x) " " (ly:number->string y) " { " s " } place-box\n")) + (format + "gsave ~a ~a translate +0 0 moveto +~a +grestore\n" -(define (polygon points blotdiameter) + (ly:number->string x) + (ly:number->string y) + s)) + +(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) @@ -305,22 +276,10 @@ (cdr y) url)) -(define (utf8-string pango-font-description string) - (ly:warning (_ "utf8-string encountered in PS backend"))) +(define (utf-8-string pango-font-description string) + (ly:warning (_ "utf-8-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