X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-ps.scm;h=575c96d8fb1771549bdab9bfda953c2cf77b60d8;hb=326d10399091bd821918dfe9b2328360a8df0d3f;hp=f784997a40b84dc5a936870cbd6045d524c94b9b;hpb=68caaced5f48737e67beb0c9c8f4517446c06dc7;p=lilypond.git diff --git a/scm/output-ps.scm b/scm/output-ps.scm index f784997a40..575c96d8fb 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 @@ -23,8 +19,6 @@ #:re-export (quote) #:export (define-fonts unknown - output-paper-def - output-scopes select-font blank dot @@ -54,32 +48,18 @@ tuplet 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) (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)) @@ -88,16 +68,11 @@ (cons (+ (car a) (car b)) (+ (cdr a) (cdr b)))) -;; WIP -(define font-encoding-alist - '(("ecrm12" . "ISOLatin1Encoding") - ("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")) @@ -108,9 +83,6 @@ (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 @@ -137,7 +109,7 @@ (define (char font i) (string-append - (font-command font) " setfont " + (ps-font-command font) " setfont " "(\\" (ly:inexact->string i 8) ") show" )) (define (comment s) @@ -166,81 +138,29 @@ (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 (fontname->designsize fontname) - (let ((i (string-index fontname char-numeric?))) - (string->number (substring fontname i)))) - - (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-public (ps-font-command font . override-coding) + (let* ((name (ly:font-filename font)) + (magnify (ly:font-magnification font)) + (coding-alist (ly:font-encoding-alist font)) + (input-encoding (assoc-get 'input-name coding-alist)) + (font-encoding (assoc-get 'output-name coding-alist)) + (coding-command (if (null? override-coding) + (if (equal? input-encoding font-encoding) + #f font-encoding) + (car override-coding)))) + + ;; FIXME: now feta stuff has feta* input-encoding (again?) + ;;(format (current-error-port) "FONT: ~S, ~S\n" name font-encoding) + ;;(format (current-error-port) "INPUT: ~S\n" input-encoding) + (if (and coding-command (equal? (substring coding-command 0 4) "feta")) + (set! coding-command #f)) - (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)) - (encoding (assoc-get fontname font-encoding-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) "mangled ~S\n" mangled) - (format (current-error-port) "designsize ~S\n" designsize) - (format (current-error-port) "foo-design ~S\n" foo-design) - (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 encoding - ;; FIXME: should rather tag encoded font - (let ((raw (string-append command "-raw"))) - (string-append - (define-font raw mangled scaling) - (reencode-font raw encoding command))) - (define-font command mangled scaling)))) - - (apply string-append - (map (lambda (x) (font-load-command paper x)) font-list))) + "magfont" (string-encode-integer (hashq name 1000000)) + "m" (string-encode-integer (inexact->exact (round (* 1000 magnify)))) + (if (not coding-command) "" (string-append "e" coding-command))))) (define (define-origin file line col) "") @@ -269,34 +189,13 @@ " /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")) @@ -308,66 +207,7 @@ (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 @@ -390,35 +230,50 @@ (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) +(define (stem breapth width depth height) ; FIXME: use draw_round_box. (string-append (ly:numbers->string (list breapth width depth height)) " draw_box" )) -(define (stop-system) - "} stop-system\n") - -(define stop-last-system stop-system) - (define (symmetric-x-triangle thick w h) (string-append (ly:numbers->string (list h w thick)) " draw_symmetric_x_triangle")) (define (text font s) - -;; (string-append "(" (escape-parentheses s) ") show ")) - (string-append - - (font-command font) " setfont " - "(" (ps-encoding s) ") show")) + (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 " ")) + (string-append + (ps-font-command font) " setfont " + (string-join (reverse commands))) + )) + (define (unknown) "\n unknown\n") @@ -432,14 +287,3 @@ (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"))