X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-ps.scm;h=75251dcbfa0b081bb8d9bafdfda2e7514d20f868;hb=49465d11fb5e62a976e41768f142ef0fb58c08c3;hp=0597ee23bf2b79690ff056f715e19b422a3d4f0d;hpb=8d186301cf0f02616e0002a6b111ba6db3ff8fbf;p=lilypond.git diff --git a/scm/output-ps.scm b/scm/output-ps.scm index 0597ee23bf..75251dcbfa 100644 --- a/scm/output-ps.scm +++ b/scm/output-ps.scm @@ -1,4 +1,4 @@ -;;;; 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 ;;;; @@ -9,11 +9,7 @@ ;;;; 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 @@ -21,64 +17,51 @@ (define-module (scm output-ps) #:re-export (quote) - #:export (define-fonts - unknown - output-paper-def - output-scopes - select-font + + ;; JUNK this -- see lily.scm: ly:all-output-backend-commands + #:export (unknown blank dot + white-dot beam bracket dashed-slur char + named-glyph 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 + embedded-ps filledbox round-filled-box text - tuplet + white-text polygon draw-line - between-system-string - define-origin no-origin - start-page - stop-page - ) -) + )) + + (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 +;;(map export +;; (append (ly:all-stencil-expressions) (ly:all-output-backend-commands))) + +;; huh? +;;(write (ly:all-output-backend-commands)) +;;(write (ly:all-stencil-expressions)) -(define OUTPUT-SCALE 4.98) -(define TOP-MARGIN 0) ;;; helper functions, not part of output interface (define (escape-parentheses s) @@ -88,26 +71,22 @@ (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,9 +98,9 @@ (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")) @@ -134,11 +113,13 @@ (define (char font i) (string-append - (font-command font) " setfont " + (ps-font-command font) " setfont " "(\\" (ly:inexact->string i 8) ") show" )) -(define (comment s) - (string-append "% " s "\n")) +(define (named-glyph font glyph) + (string-append + (ps-font-command font) " setfont " + "/" glyph " glyphshow ")) (define (dashed-line thick on off dx dy) (string-append @@ -163,85 +144,10 @@ (ly:number->string (* 10 thick)) " ] 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")) +; todo: merge with tex-font-command? - (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 (or (equal? encoding "ISOLatin1Encoding") - ;; UGH, uhg - (equal? fontname "feta20") - (equal? fontname "parmesan20")) - (define-font command mangled scaling) - ;; FIXME: should rather tag encoded font - (let ((raw (string-append command "-raw")) - (vector (get-coding-command encoding)) - (filename (get-coding-filename encoding))) - (string-append - (ly:kpathsea-gulp-file filename) - (define-font raw mangled scaling) - (reencode-font raw vector command)))))) - - (apply string-append - (map (lambda (x) (font-load-command paper x)) font-list))) - -(define (define-origin file line col) "") +(define (embedded-ps string) + string) (define (dot x y radius) (string-append @@ -249,6 +155,12 @@ (ly:numbers->string (list x y radius)) " draw_dot")) +(define (white-dot x y radius) + (string-append + " " + (ly:numbers->string + (list x y radius)) " draw_white_dot")) + (define (draw-line thick x1 y1 x2 y2) (string-append "1 setlinecap 1 setlinejoin " @@ -258,9 +170,6 @@ (ly:number->string x2) " " (ly:number->string y2) " lineto stroke")) -(define (end-output) - "\nend-lilypond-output\n") - (define (ez-ball ch letter-col ball-col) (string-append " (" ch ") " @@ -268,105 +177,22 @@ " /Helvetica-Bold " ;; ugh " draw_ez_ball")) -(define (filledbox breapth width depth height) +(define (filledbox breapth width depth height) ; FIXME : use draw_round_box (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"))) - +;; WTF is this in every backend? (define (horizontal-line x1 x2 th) - (draw-line th x1 0 x2 0)) + (draw-line th x1 0 x2 0)) (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) "") - -;; 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 (placebox x y s) (string-append @@ -389,34 +215,69 @@ (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")) - -(define (stem breapth width depth height) - (string-append - (ly:numbers->string (list breapth width depth height)) - " draw_box" )) - -(define (stop-system) - "} stop-system\n") +(define (old-text font s) + (let* + + ;; ugh, we should find a better way to + ;; extract the hsbw for /space from the font. + + ((space-length (cdar (ly:text-dimension font "t"))) + (commands '()) + (add-command (lambda (x) (set! commands (cons x commands)))) ) + + (string-fold + (lambda (chr word) + "Translate space as into moveto, group the rest in words." + (if (and (< 0 (string-length word)) + (equal? #\space chr)) + (add-command + (string-append "(" (ps-encoding word) ") show\n"))) + + (if (equal? #\space chr) + (add-command (string-append (number->string space-length) " 0.0 rmoveto ")) ) + + (if (equal? #\space chr) + "" + (string-append word (make-string 1 chr)))) + "" + (string-append s " ")) -(define stop-last-system stop-system) + (string-append + (ps-font-command font) " setfont " + (string-join (reverse commands))) + )) -(define (symmetric-x-triangle thick w h) - (string-append - (ly:numbers->string (list h w thick)) - " draw_symmetric_x_triangle")) +(define (new-text font s) + (let* + ((space-length (cdar (ly:text-dimension font "t"))) + (space-move (string-append (number->string space-length) " 0.0 rmoveto ")) + + (input-enc (assoc-get 'input-name + (ly:font-encoding-alist font) + 'latin1)) + (out-vec (decode-byte-string input-enc s))) -(define (text font s) - -;; (string-append "(" (escape-parentheses s) ") show ")) - (string-append - (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 text old-text) +(define text new-text) + +(define (white-text scale s) + (let ((mystring (string-append "(" s ") " (number->string scale) " /Helvetica-bold " + " draw_white_text"))) + mystring)) (define (unknown) "\n unknown\n") @@ -432,13 +293,9 @@ (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")) +(define (grob-cause grob) + "") + +(define (no-origin) + "")