;;;; (c) 1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
-;; TODO:
-;; * testbed for titles with markup
-;; * font size and designsize
-;; * FIXME: breaks when outputting strings with parentheses.
-
+;;;; Note: currently misused as testbed for titles with markup, see
+;;;; input/test/title-markup.ly
+;;;;
+;;;; TODO:
+;;;; * UGR: SPACE character in CM* fonts
+;;;; * text setting, kerning?
+;;;; * font size and designsize
+;;;; * linewidth
+;;;; * font properties
+;;;; * construction/customisation of title markup
+;;;; * page layout
+;;;; * document output-interface
(debug-enable 'backtrace)
(lily))
+
+
;;; Lily output interface, PostScript implementation --- cleanup and docme
-;; Module entry
+;;; Module entry
(define-public (ps-output-expression expr port)
(display (expression->string expr) port))
-
-(define (expression->string expr)
- (eval expr this-module))
-
-;; Global vars
-
+;;; Global vars
;; alist containing fontname -> fontcommand assoc (both strings)
(define font-name-alist '())
;; WIP -- stencils from markup? values of output-scopes
(define header-stencil #f)
-;; Interface functions
+(define lily-traced-cm-fonts
+ (map symbol->string
+ '(cmbx14
+ cmbx17
+ cmbxti12
+ cmbxti14
+ cmbxti6
+ cmbxti7
+ cmbxti8
+ cmcsc12
+ cmcsc7
+ cmcsc8
+ cmss5
+ cmss6
+ cmss7
+ cmti5
+ cmti6
+ cmtt17
+ cmtt5
+ cmtt6
+ cmtt7)))
+
+;;; 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))))
+
+;; FIXME: lily-def
+(define (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)
+ (number->string val)
+ (number->string (exact->inexact val)))))
+ (string-append "/" prefix (symbol->string key) " " s " def\n")))
+
+
+
+;;; Output-interface functions
(define (beam width slope thick blot)
(string-append
(numbers->string (list slope width thick blot)) " draw_beam" ))
(list arch_angle arch_width arch_height height arch_thick thick))
" draw_bracket"))
-(define (symmetric-x-triangle thick w h)
- (string-append
- (numbers->string (list h w thick))
- " draw_symmetric_x_triangle"))
-
-
(define (char i)
(string-append
"(\\" (inexact->string i 8) ") show " ))
-
(define (comment s)
(string-append "% " s "\n"))
-
(define (dashed-line thick on off dx dy)
(string-append
(ly:number->string dx)
(ly:number->string (* 10 thick))
" ] 0 draw_dashed_slur"))
-(define lily-traced-cm-fonts
- (map symbol->string
- '(cmbx14
- cmbx17
- cmbxti12
- cmbxti14
- cmbxti6
- cmbxti7
- cmbxti8
- cmcsc12
- cmcsc7
- cmcsc8
- cmss5
- cmss6
- cmss7
- cmti5
- cmti6
- cmtt17
- cmtt5
- cmtt6
- cmtt7)))
-
-
(define (define-fonts internal-external-name-mag-pairs)
(define (font-load-command name-mag command)
(numbers->string
(list x y radius)) " draw_dot"))
-(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 (draw-line thick x1 y1 x2 y2)
(string-append
" 1 setlinecap
(ly:number->string y2)
" lineto stroke"))
-(define (polygon points blotdiameter)
- (string-append
- " "
- (numbers->string points)
- (ly:number->string (/ (length points) 2))
- (ly:number->string blotdiameter)
- " draw_polygon"))
-
(define (end-output)
"\nend-lilypond-output\n")
+(define (expression->string expr)
+ (eval expr this-module))
+
(define (ez-ball ch letter-col ball-col)
(string-append
" (" ch ") "
(string-append (numbers->string (list breapth width depth height))
" draw_box"))
-(define (horizontal-line x1 x2 th)
- (draw-line th x1 0 x2 0))
-
(define (fontify name-mag-pair exp)
(define (select-font name-mag-pair)
; "\n /testing true def"
))
+(define (horizontal-line x1 x2 th)
+ (draw-line th x1 0 x2 0))
+
(define (lily-def key val)
(let ((prefix "lilypondpaper"))
(if (string=?
(string-append "/" key " {" val "} bind def\n")
(string-append "/" key " (" val ") def\n"))))
-(define (no-origin) "")
-
-(define (placebox x y s)
- (string-append
- (ly:number->string x) " " (ly:number->string y) " {" s "} place-box\n"))
-
-(define (repeat-slash wid slope thick)
- (string-append
- (numbers->string (list wid slope thick))
- " draw_repeat_slash"))
-
-(define (round-filled-box x y width height blotdiam)
- (string-append
- " "
- (numbers->string
- (list x y width height blotdiam)) " draw_round_box"))
-
-(define (start-system width height)
- (string-append
- "\n" (ly:number->string height)
- " start-system\n"
- "{\n"
- "set-ps-scale-to-lily-scale\n"))
-
-(define (stem breapth width depth height)
- (string-append
- (numbers->string (list breapth width depth height))
- " draw_box" ))
-
-(define (stop-last-system)
- (stop-system))
-
-(define (stop-system)
- "}\nstop-system\n")
-
-(define (text s)
- (string-append "(" s ") show "))
-(define (unknown)
- "\n unknown\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) (interval-length y-ext))
+ port)
+ (output-stencil port (ly:stencil-get-expr header-stencil) '(0 . 0))
+ (display (stop-system) port)))
+ "")
-;; top-of-file, wtf?
-(define (top-of-file)
- (header (string-append "GNU LilyPond (" (lilypond-version) "), ")
- (strftime "%c" (localtime (current-time))))
- ;;; ugh
- (ps-string-def
- "lilypond" 'tagline
- (string-append "Engraved by LilyPond (" (lilypond-version) ")")))
+(define (no-origin) "")
+;; FIXME: duplictates output-scopes, duplicated in other backends
+;; FIXME: silly interface name
(define (output-paper-def pd)
- (apply
- string-append
- (module-map
- (lambda (sym var)
- (let ((val (variable-ref var))
- (key (symbol->string sym)))
-
+ (let ((prefix "lilypondpaper"))
+
+ (define (scope-entry->string key var)
+ (let ((val (variable-ref var)))
(cond
- ((string? val)
- (ps-string-def "lilypondpaper" sym val))
- ((number? val)
- (ps-number-def "lilypondpaper" sym
- (if (integer? val)
- (number->string val)
- (number->string (exact->inexact val)))))
+ ((string? val) (ps-string-def prefix key val))
+ ((number? val) (ps-number-def prefix key val))
(else ""))))
- (ly:output-def-scope pd))))
-
-
-(define (ps-string-def a b c)
- (string-append "/" a (symbol->string b) " (" c ") def\n"))
-
-(define (ps-number-def a b c)
- (string-append "/" a (symbol->string b) " " c " def\n"))
-
+ (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)
;; FIXME: customise/generate these
(font-style . roman)
(font-shape . upright)
(font-size . 0))))
- (stencils '())
+ (prefix "lilypond")
+ (stencils '())
(baseline-skip 2))
- (define (output-scope-entry sym var)
- (let ((val (variable-ref var))
- (tex-key (symbol->string sym)))
+ (define (scope-entry->string key var)
+ (let ((val (variable-ref var)))
- (if (memq sym fields)
- (header-to-file basename sym val))
+ (if (memq key fields)
+ (header-to-file basename key val))
(cond
- ((eq? sym 'font)
+ ((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 "lilypond" sym val))
+ ((string? val) (ps-string-def prefix key val))
;; generate stencil from markup
((markup? val) (set! stencils
(list
(interpret-markup paper props val))))
"")
- ((number? val) (ps-number-def
- "lilypond" sym (if (integer? val)
- (number->string val)
- (number->string
- (exact->inexact val)))))
+ ((number? val) (ps-number-def prefix key val))
(else ""))))
(define (output-scope scope)
- (apply string-append (module-map output-scope-entry 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))
(ly:stencil-get-expr header-stencil)
s)))
-(define (offset-add a b)
- (cons (+ (car a) (car b))
- (+ (cdr a) (cdr b))))
-
-(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) (interval-length y-ext))
- port)
- (output-stencil port (ly:stencil-get-expr header-stencil) '(0 . 0))
- (display (stop-system) port)))
- "")
-
;; hmm, looks like recursing call is always last statement, does guile
;; think so too?
(define (output-stencil port expr offset)
(display (placebox (car offset) (cdr offset)
(expression->string expr)) port))))))
+(define (placebox x y s)
+ (string-append
+ (ly:number->string x) " " (ly:number->string y) " {" s "} place-box\n"))
+
+(define (polygon points blotdiameter)
+ (string-append
+ " "
+ (numbers->string points)
+ (ly:number->string (/ (length points) 2))
+ (ly:number->string blotdiameter)
+ " draw_polygon"))
+
+(define (repeat-slash wid slope thick)
+ (string-append
+ (numbers->string (list wid slope thick))
+ " draw_repeat_slash"))
+
+(define (round-filled-box x y width height blotdiam)
+ (string-append
+ " "
+ (numbers->string
+ (list x y width height blotdiam)) " draw_round_box"))
+
+(define (symmetric-x-triangle thick w h)
+ (string-append
+ (numbers->string (list h w thick))
+ " draw_symmetric_x_triangle"))
+
+(define (start-system width height)
+ (string-append
+ "\n" (ly:number->string height)
+ " start-system\n"
+ "{\n"
+ "set-ps-scale-to-lily-scale\n"))
+
+(define (stem breapth width depth height)
+ (string-append
+ (numbers->string (list breapth width depth height))
+ " draw_box" ))
+
+(define (stop-last-system)
+ (stop-system))
+
+(define (stop-system)
+ "}\nstop-system\n")
+
+(define (text s)
+ (string-append "(" (escape-parentheses s) ") show "))
+
+;; top-of-file, wtf?
+(define (top-of-file)
+ (header (string-append "GNU LilyPond (" (lilypond-version) "), ")
+ (strftime "%c" (localtime (current-time))))
+ ;;; ugh
+ (ps-string-def
+ "lilypond" 'tagline
+ (string-append "Engraved by LilyPond (" (lilypond-version) ")")))
+
+(define (unknown)
+ "\n unknown\n")
+
+(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 "))
projects / lilypond.git / commitdiff