X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-ps.scm;h=fe168a103ffca1302e729a9f21d02881d7ed09ae;hb=57244befefb4bb8aad0f43e85da56ea378d64974;hp=a2ef3d9512dff979b8b72276dbe54b592b0b8f1b;hpb=31af66bfb9dfc2bbc8d7941e343e0b16a8ca8631;p=lilypond.git diff --git a/scm/output-ps.scm b/scm/output-ps.scm index a2ef3d9512..fe168a103f 100644 --- a/scm/output-ps.scm +++ b/scm/output-ps.scm @@ -1,113 +1,74 @@ -;;;; output-ps.scm -- implement Scheme output routines for PostScript +;;;; output-ps.scm -- implement Scheme output interface for PostScript ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 1998--2004 Jan Nieuwenhuizen +;;;; (c) 1998--2005 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys ;;;; Note: currently misused as testbed for titles with markup, see ;;;; input/test/title-markup.ly ;;;; ;;;; TODO: -;;;; * papersize in header -;;;; * special characters, encoding. -;;;; + implement encoding switch (switches? input/output??), -;;;; + move encoding definitions to ENCODING.ps files, or -;;;; + find out which program's PS(?) encoding code we can use? +;;;; * %% Papersize in (header ...) ;;;; * text setting, kerning. ;;;; * document output-interface -(debug-enable 'backtrace) - (define-module (scm output-ps) #:re-export (quote) - #:export (define-fonts - unknown - output-paper-def - output-scopes - select-font - blank - dot - beam - bracket - dashed-slur - char - dashed-line - zigzag-line - symmetric-x-triangle - ez-ball - comment - end-output - experimental-on - repeat-slash - header-end - header - placebox - bezier-sandwich - start-system - stop-system - stop-last-system - horizontal-line - filledbox - round-filled-box - text - tuplet - polygon - draw-line - between-system-string - define-origin - no-origin - start-page - stop-page - ) -) + + ;; JUNK this -- see lily.scm: ly:all-output-backend-commands + #:export (unknown + blank + circle + dot + beam + dashed-slur + char + setcolor + resetcolor + named-glyph + dashed-line + zigzag-line + comment + repeat-slash + placebox + bezier-sandwich + embedded-ps + filledbox + round-filled-box + text + polygon + draw-line + no-origin)) + + (use-modules (guile) (ice-9 regex) + (srfi srfi-1) (srfi srfi-13) + (scm framework-ps) (lily)) -;;; Global vars -;; alist containing fontname -> fontcommand assoc (both strings) -(define page-count 0) -(define page-number 0) - -;; /lilypondpaperoutputscale 1.75729901757299 def -;;/lily-output-units 2.83464 def %% milimeter -;;/output-scale lilypondpaperoutputscale lily-output-units mul def -;; -;; output-scale = 1.75729901757299 * 2.83464 = 4.9813100871731003736 - -(define OUTPUT-SCALE 4.98) -(define TOP-MARGIN 0) - ;;; helper functions, not part of output interface (define (escape-parentheses s) (regexp-substitute/global #f "(^|[^\\])([\\(\\)])" s 'pre 1 "\\" 2 'post)) -(define (offset-add a b) - (cons (+ (car a) (car b)) - (+ (cdr a) (cdr b)))) - -;; ("ecmb12" . "ISOLatin1Encoding"))) - (define (ps-encoding text) (escape-parentheses text)) ;; FIXME: lily-def -(define (ps-string-def prefix key val) +(define-public (ps-string-def prefix key val) (string-append "/" prefix (symbol->string key) " (" (escape-parentheses val) ") def\n")) + (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"))) -(define (tex-font? fontname) - (equal? (substring fontname 0 2) "cm")) - ;;; ;;; Lily output interface, PostScript implementation --- cleanup and docme @@ -119,26 +80,24 @@ (ly:numbers->string (list slope width thick blot)) " draw_beam" )) ;; two beziers -(define (bezier-sandwich l thick) +(define (bezier-sandwich lst thick) (string-append - (string-join (map ly:number-pair->string l) " ") + (string-join (map ly:number-pair->string lst) " ") " " (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 - (font-command font) " setfont " - "(\\" (ly:inexact->string i 8) ") show" )) + (ps-font-command font) " setfont " + "(\\" (ly:inexact->string i 8) ") show")) -(define (comment s) - (string-append "% " s "\n")) +(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 @@ -151,105 +110,17 @@ " ] 0 draw_dashed_line")) ;; what the heck is this interface ? -(define (dashed-slur thick dash l) +(define (dashed-slur thick on off l) (string-append (string-join (map ly:number-pair->string l) " ") " " (ly:number->string thick) " [ " - (ly:number->string dash) - " " - ;;UGH. 10 ? - (ly:number->string (* 10 thick)) + (ly:number->string on) + " " + (ly:number->string off) " ] 0 draw_dashed_slur")) -(define (font-command font) - (string-append - "magfont" - (string-encode-integer - (hashq (ly:font-name font) 1000000)) - "m" - (string-encode-integer - (inexact->exact (round (* 1000 (ly:font-magnification font))))))) - -(define (define-fonts paper font-list) - (define (define-font command fontname scaling) - (string-append - "/" command " { /" fontname " findfont " - ;; FIXME - (ly:number->string scaling) " output-scale div scalefont } bind def\n")) - ;;(ly:number->string scaling) " scalefont } bind def\n")) - - (define (reencode-font raw encoding command) - (string-append - raw " " encoding " /" command " reencode-font\n" - "/" command "{ /" command " findfont 1 scalefont } bind def\n")) - - ;; frobnicate NAME to jibe with external definitions. - (define (possibly-mangle-fontname fontname) - (cond - ((tex-font? fontname) - ;; FIXME: we need proper Fontmap for CM fonts, like so: - ;; /CMR10 (cmr10.pfb); - ;; (string-upcase fontname) - (string-append fontname ".pfb")) - ((or (equal? (substring fontname 0 4) "feta") - (equal? (substring fontname 0 4) "parm")) - (regexp-substitute/global - #f "(feta|parmesan)([a-z-]*)([0-9]+)" - fontname 'pre "GNU-LilyPond-" 1 2 "-" 3 'post)) - (else fontname))) - - (define (font-load-command paper font) - (let* ((command (font-command font)) - (fontname (ly:font-name font)) - (mangled (possibly-mangle-fontname fontname)) - (coding-alist (ly:font-encoding-alist font)) - (encoding (assoc-get 'input-name coding-alist)) - (designsize (ly:font-design-size font)) - (magnification (* (ly:font-magnification font))) - (ops (ly:paper-lookup paper 'outputscale)) - (scaling (* ops magnification designsize))) - - (if - #f - (begin - (newline) - (format (current-error-port) "fontname ~S\n" fontname) - (format (current-error-port) "command ~S\n" command) - (format (current-error-port) "encoding name ~S\n" encoding) - (format (current-error-port) "mangled ~S\n" mangled) - (format (current-error-port) "designsize ~S\n" designsize) - (format (current-error-port) "magnification ~S\n" magnification) - (format (current-error-port) "ops ~S\n" ops) - (format (current-error-port) "scaling ~S\n" scaling))) - - (if (equal? encoding "AdobeStandardEncoding") - (define-font command mangled scaling) - ;; FIXME: should rather tag encoded font - (let ((raw (string-append command "-raw")) - (vector (get-coding-command encoding))) - (string-append - (define-font raw mangled scaling) - (reencode-font raw vector command)))))) - - (define (font-load-encoding encoding) - (let ((filename (get-coding-filename encoding))) - (ly:kpathsea-gulp-file filename))) - - (let* ((encoding-list (map (lambda (x) - (assoc-get 'input-name - (ly:font-encoding-alist x))) - font-list)) - (encodings (uniq-list (sort-list encoding-list stringstring x2) " " (ly:number->string y2) " lineto stroke")) -(define (end-output) - "\nend-lilypond-output\n") +(define (embedded-ps string) + string) -(define (ez-ball ch letter-col ball-col) - (string-append - " (" ch ") " - (ly:numbers->string (list letter-col ball-col)) - " /Helvetica-Bold " ;; ugh - " draw_ez_ball")) - -(define (filledbox breapth width depth height) +;; FIXME: use draw_round_box +(define (filledbox breapth width depth height) (string-append (ly:numbers->string (list breapth width depth height)) " draw_box")) -(define (header creator time-stamp page-count-) - (set! page-count page-count-) - (set! page-number 0) - (string-append - "%!PS-Adobe-3.0\n" - "%%Creator: " creator " " time-stamp "\n" - "%%Pages: " (number->string page-count) "\n" - "%%PageOrder: Ascend\n" - ;; FIXME: TODO get from paper - ;; "%%DocumentPaperSizes: a6\n" - ;;(string-append "GNU LilyPond (" (lilypond-version) "), ") - ;; (strftime "%c" (localtime (current-time)))) - ;; FIXME: duplicated in every backend - (ps-string-def - "lilypond" 'tagline - (string-append "Engraved by LilyPond (version " (lilypond-version) ")")))) - -(define (header-end) - (string-append - (ly:gulp-file "lilyponddefs.ps") - (ly:gulp-file "music-drawing-routines.ps"))) +(define (glyph-string + postscript-font-name + size cid? + x-y-named-glyphs) -(define (horizontal-line x1 x2 th) - (draw-line th x1 0 x2 0)) + (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 ~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)))) + (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 "lilypondpaper")) + (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")))) -(define (no-origin) "") +(define (named-glyph font glyph) + (string-append + (ps-font-command font) " setfont " + "/" glyph " glyphshow ")) -;; FIXME: duplictates output-scopes, duplicated in other backends -;; FIXME: silly interface name -(define (output-paper-def pd) - (let ((prefix "lilypondpaper")) - - (define (scope-entry->string key var) - (if (variable-bound? var) - (let ((val (variable-ref var))) - (cond - ((string? val) (ps-string-def prefix key val)) - ((number? val) (ps-number-def prefix key val)) - (else ""))) - "")) - - (apply - string-append - (module-map scope-entry->string (ly:output-def-scope pd))))) - -;; FIXME: duplicated in other output backends -;; FIXME: silly interface name -(define (output-scopes paper scopes fields basename) - (let ((prefix "lilypond")) - - ;; FIXME: duplicates output-paper's scope-entry->string, mostly - (define (scope-entry->string key var) - (if (variable-bound? var) - (let ((val (variable-ref var))) - (if (and (memq key fields) (string? val)) - (header-to-file basename key val)) - (cond - ((string? val) (ps-string-def prefix key val)) - ((number? val) (ps-number-def prefix key val)) - (else ""))) - "")) - - (define (output-scope scope) - (apply string-append (module-map scope-entry->string scope))) - - (string-append (apply string-append (map output-scope scopes))))) - -;; hmm, looks like recursing call is always last statement, does guile -;; think so too? -(define (output-stencil port expr offset) - (if (pair? expr) - (let ((head (car expr))) - (cond - ((ly:input-location? head) - (display (apply define-origin (ly:input-location head)) port) - (output-stencil port (cadr expr) offset)) - ((eq? head 'no-origin) - (display (expression->string head) port) - (output-stencil port (cadr expr) offset)) - ((eq? head 'translate-stencil) - (output-stencil port (caddr expr) (offset-add offset (cadr expr)))) - ((eq? head 'combine-stencil) - (output-stencil port (cadr expr) offset) - (output-stencil port (caddr expr) offset)) - (else - (display (placebox (car offset) (cdr offset) - (expression->string expr)) port)))))) +(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) +(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) @@ -391,61 +251,65 @@ (ly:numbers->string (list wid slope thick)) " draw_repeat_slash")) -(define (round-filled-box x y width height blotdiam) - (string-append - (ly:numbers->string - (list x y width height blotdiam)) " draw_round_box")) - -(define (new-start-system origin dim) - (string-append - "\n" (ly:number-pair->string origin) " start-system\n" - "{\n" - "set-ps-scale-to-lily-scale\n")) +;; restore color from stack +(define (resetcolor) + (string-append "setrgbcolor\n")) -(define (stem breapth width depth height) +(define (round-filled-box x y width height blotdiam) (string-append - (ly:numbers->string (list breapth width depth height)) - " draw_box" )) - -(define (stop-system) - "} stop-system\n") - -(define stop-last-system stop-system) + (ly:numbers->string + (list x y width height blotdiam)) " draw_round_box")) -(define (symmetric-x-triangle thick w h) - (string-append - (ly:numbers->string (list h w thick)) - " draw_symmetric_x_triangle")) +;; 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")) + ;; (ly:warning (_ "Arguments: ~a ~a"" font str)) -;; (string-append "(" (escape-parentheses s) ") show ")) - (string-append + (let* ((space-length (cdar (ly:text-dimension font " "))) + (space-move (string-append (number->string space-length) + " 0.0 rmoveto ")) + (out-vec (decode-byte-string s))) - (font-command font) " setfont " - "(" (ps-encoding s) ") show")) + (string-append + (ps-font-command font) " setfont " + (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) "\n unknown\n") +(define (url-link url x y) + (format "~a ~a ~a ~a (~a) mark_URI" + (car x) + (car y) + (cdr x) + (cdr y) + url)) + +(define (utf8-string pango-font-description string) + (ly:warning (_ "utf8-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")) - -(define (start-page) - (set! page-number (+ page-number 1)) - (string-append - "%%Page: " (number->string page-number) " " (number->string page-count) "\n" - "start-page\n")) - -(define (stop-page last?) - (if last? - "\nstop-last-page\n" - "\nstop-page\n")) + (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"))