;;;; source file of the GNU LilyPond music typesetter
;;;;
;;;; (c) 1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
+;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
;;;; Note: currently misused as testbed for titles with markup, see
;;;; input/test/title-markup.ly
;;;;
;;;; TODO:
;;;; * 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?
;;;; * text setting, kerning.
-;;;; * font properties
-;;;; * customisation of title markup, piece title markup?
-;;;; * page layout
;;;; * document output-interface
(debug-enable 'backtrace)
;;; Lily output interface, PostScript implementation --- cleanup and docme
-;;; Module entry
+;;; Output interface entry
(define-public (ps-output-expression expr port)
(display (expression->string expr) port))
;; alist containing fontname -> fontcommand assoc (both strings)
(define font-name-alist '())
-;; WIP -- stencils from markup? values of output-scopes
-(define header-stencil #f)
-
-(define BASELINE-SKIP 3)
-
;; /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)
-(define PROPS `(((font-family . roman)
- (word-space . 1)
- (baseline-skip . ,BASELINE-SKIP)
- (font-series . medium)
- (font-style . roman)
- (font-shape . upright)
- (font-size . 0))))
-
;;; helper functions, not part of output interface
(define (escape-parentheses s)
(cons (+ (car a) (car b))
(+ (cdr a) (cdr b))))
-(define LATIN1-ENCODING-ALIST
- '(("ö" . "oumlaut")
- ("ò" . "ograve")
- ("ó" . "oacute")
- ("ô" . "ocircumflex")
- ("õ" . "otilde")
- ("ø" . "oslash")))
-
-(define LATIN1-ENCODING-COMMANDS
- "/oumlaut { (o) show gsave -1 0 rmoveto (\\177) show grestore } bind def
-/ograve { (o) show gsave -1 0 rmoveto (\\022) show grestore } def
-/oacute { (o) show gsave -1 0 rmoveto (\\023) show grestore } def
-/ocircumflex { (o) show gsave -1 0 rmoveto (^) show grestore } def
-/otilde { (o) show gsave -1 0 rmoveto (~) show grestore } def
-/oslash { (o) show gsave -1 0 rmoveto (\\034) show grestore } def
-")
-
+;; WIP
+(define font-encoding-alist
+ '(("ecrm12" . "ISOLatin1Encoding")
+ ("ecmb12" . "ISOLatin1Encoding")))
+
(define (ps-encoding text)
- (let ((s (escape-parentheses text)))
- (define (helper alist-list s)
- (if (not (pair? alist-list))
- s
- (helper (cdr alist-list)
- (regexp-substitute/global
- #f (caar alist-list) s
- 'pre (string-append ") show " (cdar alist-list) " (")
- 'post))))
- (helper LATIN1-ENCODING-ALIST s)))
+ (escape-parentheses text))
;; FIXME: lily-def
(define (ps-string-def prefix key val)
(define (tex-font? fontname)
(equal? (substring fontname 0 2) "cm"))
-
-
;;; Output-interface functions
(define (beam width slope thick blot)
(string-append
(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 "
+ (ly:number->string scaling) " output-scale div 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 name-mag command)
(define (font-load-command lst)
(value-name-size (car value))
(command (cdr value))
(fontname (car value-name-size))
+ (mangled (possibly-mangle-fontname fontname))
+ (encoding (assoc-get fontname font-encoding-alist))
(designsize (if (tex-font? fontname)
(/ 12 (fontname->designsize fontname))
;; This is about 12/20 :-)
(scaling (* 12 (/ fontsize designsize)))
(scaling (/ fontsize (/ designsize 12))))
- ;; 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 8) "parmesan"))
- (regexp-substitute/global
- #f "(feta|parmesan)([a-z-]*)([0-9]+)"
- fontname 'pre "GNU-LilyPond-" 1 2 "-" 3 'post))
- (else fontname)))
(if
#f
(begin
(format (current-error-port) "command ~S\n" command)
(format (current-error-port) "designsize ~S\n" designsize)
(format (current-error-port) "fontname ~S\n" fontname)
+ (format (current-error-port) "mangled ~S\n" mangled)
(format (current-error-port) "fontsize ~S\n" fontsize)
(format (current-error-port) "scaling ~S\n" scaling)))
-
- (string-append
- "/" command
- " { /" (possibly-mangle-fontname fontname) " findfont "
- (ly:number->string scaling)
- "output-scale div scalefont setfont } bind def \n")))
-
+
+ (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))))
+
(define (ps-encoded-fontswitch name-mag-pair)
(let* ((key (car name-mag-pair))
(value (cdr name-mag-pair))
(let ((c (assoc name-mag-pair font-name-alist)))
(if c
- (string-append " " (cddr c) " ")
+ (string-append " " (cddr c) " setfont ")
(begin
(ly:warn
(format "Programming error: No such font: ~S" name-mag-pair))
-
- (display "FAILED\n" (current-error-port))
- (if #f ;(pair? name-mag-pair))
- (display (object-type (car name-mag-pair)) (current-error-port))
- (write name-mag-pair (current-error-port)))
- (if #f ; (pair? font-name-alist)
- (display
- (object-type (caaar font-name-alist)) (current-error-port))
- (write font-name-alist (current-error-port)))
-
- ;; (format #f "\n%FAILED: (select-font ~S)\n" name-mag-pair))
""))))
(string-append (select-font name-mag-pair) exp))
(define (header-end)
(string-append
- ;; URG: now we can't use scm output without Lily
(ly:gulp-file "lilyponddefs.ps")
- "{exch pop //systemdict /run get exec}\n\n"
- (ly:gulp-file "music-drawing-routines.ps")
- "{ exch pop //systemdict /run get exec }\n\n"
- ;; ps-testing wreaks havoc when used with lilypond-book.
- ;; -- is this still true with new modules system?
-;; (if (defined? 'ps-testing) "\n /testing true def" "")
- ; "\n /testing true def"
- ))
+ (ly:gulp-file "music-drawing-routines.ps")))
(define (horizontal-line x1 x2 th)
(draw-line th x1 0 x2 0))
(string-append "/" key " {" val "} bind def\n")
(string-append "/" key " (" val ") def\n"))))
-(define (make-title port)
- (if header-stencil
- (let ((x-ext (ly:stencil-get-extent header-stencil Y))
- (y-ext (ly:stencil-get-extent header-stencil X)))
- (display (start-system
- (/ (interval-length x-ext) OUTPUT-SCALE)
- (/ (interval-length y-ext) OUTPUT-SCALE))
- port)
- (output-stencil port (ly:stencil-get-expr header-stencil) '(0 . 0))
- (display (stop-system) port)))
- "")
-
(define (no-origin) "")
;; FIXME: duplictates output-scopes, duplicated in other backends
;; FIXME: duplicated in other output backends
;; FIXME: silly interface name
(define (output-scopes paper scopes fields basename)
+ (let ((prefix "lilypond"))
- ;; FIXME: customise/generate these
- (let* ((linewidth (ly:paper-get-number paper 'linewidth))
- (props (cons (acons 'linewidth linewidth '()) PROPS))
- (prefix "lilypond")
- (stencils '()))
-
+ ;; FIXME: duplicates output-paper's scope-entry->string, mostly
(define (scope-entry->string key var)
- (let ((val (variable-ref var)))
-
- (if (memq key fields)
- (header-to-file basename key val))
-
- (cond
- ((eq? key 'font)
- BARF
- (format (current-error-port) "PROPS:~S\n" val)
- (set! props (cons val props))
- "")
-
- ;; define strings, for /make-lilypond-title to pick up
- ((string? val) (ps-string-def prefix key val))
-
- ;; generate stencil from markup
- ((markup? val) (set! stencils
- (append
- stencils
- (list
- (interpret-markup paper props val))))
- "")
- ((number? val) (ps-number-def prefix key val))
- (else ""))))
+ (if (variable-bound? var)
+ (let ((val (variable-ref var)))
+ (if (memq key fields)
+ (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)))
- (let ((s (string-append (apply string-append (map output-scope scopes)))))
- (set! header-stencil (stack-lines DOWN 0 BASELINE-SKIP stencils))
-
- ;; match systems, which are also aligned to center
- (ly:stencil-align-to! header-stencil Y CENTER)
-
- ;; trigger font load
- (ly:stencil-get-expr header-stencil)
- s)))
+ (string-append (apply string-append (map output-scope scopes)))))
;; hmm, looks like recursing call is always last statement, does guile
;; think so too?
(string-append
"\n" (ly:number->string height)
" start-system\n"
+ ;; Show height of system
+ (draw-line 1 0 0 (- 0 10) (- 0 (* OUTPUT-SCALE height)))
"{\n"
"set-ps-scale-to-lily-scale\n"))
(string-append
(header (string-append "GNU LilyPond (" (lilypond-version) "), ")
(strftime "%c" (localtime (current-time))))
- LATIN1-ENCODING-COMMANDS
;;; ugh
(ps-string-def
"lilypond" 'tagline
" "
(ly:number->string dy)
" draw_zigzag_line "))
+
+(define (start-page)
+ "\nstart-page\n")
+
+(define (stop-page last?)
+ "\nstop-page\n")
projects / lilypond.git / blobdiff