-;;; ps.scm -- implement Scheme output routines for PostScript
-;;;
-;;; source file of the GNU LilyPond music typesetter
-;;;
-;;; (c) 1998--2002 Jan Nieuwenhuizen <janneke@gnu.org>
-;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
+;;;; ps.scm -- implement Scheme output routines for PostScript
+;;;;
+;;;; source file of the GNU LilyPond music typesetter
+;;;;
+;;;; (c) 1998--2002 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
+(debug-enable 'backtrace)
-(define-module
- (scm ps)
- )
+(define-module (scm ps))
+(define this-module (current-module))
-(define font-name-alist '())
+(use-modules
+ (guile)
+ (lily))
-(define this-module (current-module))
-(debug-enable 'backtrace)
-(if (or (equal? (minor-version) "4.1")
- (equal? (minor-version) "4")
- (equal? (minor-version) "3.4"))
- (define-public (ps-output-expression expr port)
- (display (eval-in-module expr this-module) port))
+;;; Lily output interface --- cleanup and docme
- (define-public (ps-output-expression expr port)
- (display (eval expr this-module) port)))
-
-(use-modules
- (guile)
- (lily)
-)
-
-
-
-;;;;;;;;
-;;;;;;;; DOCUMENT ME!
-;;;;;;;;
-(define (tex-encoded-fontswitch name-mag)
- (let* ((iname-mag (car name-mag))
- (ename-mag (cdr name-mag)))
- (cons iname-mag
- (cons ename-mag
- (string-append "magfont"
- (string-encode-integer
- (hashq (car ename-mag) 1000000))
- "m"
- (string-encode-integer
- (inexact->exact (* 1000 (cdr ename-mag)))))))))
-(define (fontify name-mag-pair exp)
- (string-append (select-font name-mag-pair)
- exp))
+;; Module entry
+(define-public (ps-output-expression expr port)
+ (display (eval expr this-module) port))
-(define (define-fonts internal-external-name-mag-pairs)
- (set! font-name-alist (map tex-encoded-fontswitch
- internal-external-name-mag-pairs))
- (apply string-append
- (map (lambda (x)
- (font-load-command (car x) (cdr x)))
- (map cdr font-name-alist))))
+;; Global vars
;; alist containing fontname -> fontcommand assoc (both strings)
-(define font-alist '())
-(define font-count 0)
-(define current-font "")
-
-(define (select-font name-mag-pair)
- (let*
- (
- (c (assoc name-mag-pair font-name-alist))
- )
-
- (if (eq? c #f)
- (begin
- (display "FAILED\n")
- (display (object-type (car name-mag-pair)))
- (display (object-type (caaar font-name-alist)))
-
- (ly:warn (string-append
- "Programming error: No such font known "
- (car name-mag-pair) " "
- (ly:number->string (cdr name-mag-pair))
- ))
-
- "") ; issue no command
- (string-append " " (cddr c) " "))
- ))
-
-(define (font-load-command name-mag command)
- (string-append
- "/" command
- " { /"
- (capitalize-font-name (car name-mag))
- " findfont "
- "20 " (ly:number->string (cdr name-mag)) " mul "
- "output-scale div scalefont setfont } bind def "
- "\n"))
-
-;; Ugh, the Bluesky type1 fonts for computer modern use capitalized
-;; postscript font names.
-(define (capitalize-font-name name)
- (if (equal? (substring name 0 2) "cm")
- (string-upcase name)
- name))
+(define font-name-alist '())
+
+;; Interface functions
(define (beam width slope thick)
(string-append
(numbers->string (list slope width thick)) " draw_beam" ))
-(define (comment s)
- (string-append "% " s "\n"))
+;; two beziers with round endings
+(define (bezier-bow l thick)
+
+ (define (bezier-ending z0 z1 z2)
+ (let ((x0 (car z0))
+ (y0 (cdr z0))
+ (x1 (car z1))
+ (y1 (cdr z1))
+ (x2 (car z2))
+ (y2 (cdr z2)))
+ (string-append
+ " "
+ (numbers->string
+ (list x0 y0
+ (/ (sqrt (+ (* (- x1 x2) (- x1 x2)) (* (- y1 y2) (- y1 y2)))) 2)))
+ " draw_dot")))
+
+ (string-append
+ (apply string-append (map number-pair->string l))
+ (ly:number->string thick)
+ " draw_bezier_sandwich "
+ (bezier-ending (list-ref l 3) (list-ref l 0) (list-ref l 5))
+ (bezier-ending (list-ref l 7) (list-ref l 0) (list-ref l 5))))
+
+;; two beziers
+(define (bezier-sandwich l thick)
+ (string-append
+ (apply string-append (map number-pair->string l))
+ (ly:number->string thick)
+ " draw_bezier_sandwich "))
(define (bracket arch_angle arch_width arch_height height arch_thick thick)
(string-append
- (numbers->string (list arch_angle arch_width arch_height height arch_thick thick)) " draw_bracket" ))
+ (numbers->string
+ (list arch_angle arch_width arch_height height arch_thick thick))
+ " draw_bracket"))
(define (char i)
- (invoke-char " show" i))
-
-
-
-;; what the heck is this interface ?
-(define (dashed-slur thick dash l)
(string-append
- (apply string-append (map number-pair->string l))
- (ly:number->string thick)
- " [ "
- (ly:number->string dash)
- " "
- (ly:number->string (* 10 thick)) ;UGH. 10 ?
- " ] 0 draw_dashed_slur"))
+ "(\\" (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 off)
" ] 0 draw_dashed_line"))
-(define (draw-line thick x1 y1 x2 y2)
+;; what the heck is this interface ?
+(define (dashed-slur thick dash l)
+ (string-append
+ (apply string-append (map number-pair->string l))
+ (ly:number->string thick)
+ " [ "
+ (ly:number->string dash)
+ " "
+ ;;UGH. 10 ?
+ (ly:number->string (* 10 thick))
+ " ] 0 draw_dashed_slur"))
+(define (define-fonts internal-external-name-mag-pairs)
+
+ (define (font-load-command name-mag command)
+
+ (define (possibly-capitalize-font-name name)
+ (if (equal? (substring name 0 2) "cm")
+ (string-upcase name)
+ name))
+
+ (string-append
+ "/" command
+ " { /"
+ ;; Ugh, the Bluesky type1 fonts for computer modern use capitalized
+ ;; postscript font names.
+ (possibly-capitalize-font-name (car name-mag))
+ " findfont "
+ "20 " (ly:number->string (cdr name-mag)) " mul "
+ "output-scale div scalefont setfont } bind def "
+ "\n"))
+
+ (define (ps-encoded-fontswitch name-mag-pair)
+ (let* ((key (car name-mag-pair))
+ (value (cdr name-mag-pair)))
+ (cons key
+ (cons value
+ (string-append "lilyfont"
+ (car value)
+ "-"
+ (number->string (cdr value)))))))
+
+ (set! font-name-alist (map ps-encoded-fontswitch
+ internal-external-name-mag-pairs))
+
+ (apply string-append
+ (map (lambda (x) (font-load-command (car x) (cdr x)))
+ (map cdr font-name-alist))))
+
+(define (define-origin file line col) "")
+
+(define (dot x y radius)
+ (string-append
+ " "
+ (numbers->string
+ (list x y radius)) " draw_dot"))
+
+(define (draw-line thick x1 y1 x2 y2)
(string-append
" 1 setlinecap
1 setlinejoin "
(ly:number->string x2)
" "
(ly:number->string y2)
- " lineto stroke"
-
- ))
-
-(define (repeat-slash wid slope thick)
- (string-append (numbers->string (list wid slope thick))
- " draw_repeat_slash"))
+ " lineto stroke"))
(define (end-output)
"\nend-lilypond-output\n")
-(define (experimental-on) "")
+(define (ez-ball ch letter-col ball-col)
+ (string-append
+ " (" ch ") "
+ (numbers->string (list letter-col ball-col))
+ " /Helvetica-Bold " ;; ugh
+ " draw_ez_ball"))
(define (filledbox breapth width depth height)
(string-append (numbers->string (list breapth width depth height))
" draw_box" ))
-(define (roundfilledbox x y width height blotdiam)
- (string-append " "
- (numbers->string
- (list x y width height blotdiam)) " draw_round_box"))
+(define (fontify name-mag-pair exp)
-(define (dot x y radius)
- (string-append " "
- (numbers->string
- (list x y radius)) " draw_dot"))
+ (define (select-font name-mag-pair)
+ (let* ((c (assoc name-mag-pair font-name-alist)))
+ (if (eq? c #f)
+ (begin
+ (display "FAILED\n")
+ (display (object-type (car name-mag-pair)))
+ (display (object-type (caaar font-name-alist)))
+ (ly:warn (string-append
+ "Programming error: No such font known "
+ (car name-mag-pair) " "
+ (ly:number->string (cdr name-mag-pair))))
+
+ ;; Upon error, issue no command
+ "")
+ (string-append " " (cddr c) " "))))
+
+ (string-append (select-font name-mag-pair) exp))
-;; obsolete?
-(define (font-def i s)
+(define (header creator generate)
(string-append
- "\n/" (font i) " {/"
- (substring s 0 (- (string-length s) 4))
- " findfont 12 scalefont setfont} bind def \n"))
-
-(define (font-switch i)
- (string-append (font i) " "))
+ "%!PS-Adobe-3.0\n"
+ "%%Creator: " creator generate "\n"))
(define (header-end)
(string-append
" {exch pop //systemdict /run get exec} "
(ly:gulp-file "music-drawing-routines.ps")
"{ exch pop //systemdict /run get exec } "
-
-;; ps-testing wreaks havoc when used with lilypond-book.
-;; (if (defined? 'ps-testing) "\n /testing true def" "")
-
-
+ ;; 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"
))
(define (lily-def key val)
+ (let ((prefix "lilypondpaper"))
+ (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"))))
- (if (string=? (substring key 0 (min (string-length "lilypondpaper") (string-length key))) "lilypondpaper")
- (string-append "/" key " {" val "} bind def\n")
- (string-append "/" key " (" val ") def\n")
- )
- )
-
-(define (header creator generate)
- (string-append
- "%!PS-Adobe-3.0\n"
- "%%Creator: " creator generate "\n"))
-
-(define (invoke-char s i)
- (string-append
- "(\\" (inexact->string i 8) ") " s " " ))
-
-
+(define (no-origin) "")
+
(define (placebox x y s)
(string-append
(ly:number->string x) " " (ly:number->string y) " {" s "} place-box\n"))
-;; two beziers
-(define (bezier-sandwich l thick)
- (string-append
- (apply string-append (map number-pair->string l))
- (ly:number->string thick)
- " draw_bezier_sandwich "))
-
-;; two beziers with round endings
-(define (bezier-bow l thick)
- (string-append
- (apply string-append (map number-pair->string l))
- (ly:number->string thick)
- " draw_bezier_sandwich "
- (bezier-ending (list-ref l 3) (list-ref l 0) (list-ref l 5))
- (bezier-ending (list-ref l 7) (list-ref l 0) (list-ref l 5))))
+(define (repeat-slash wid slope thick)
+ (string-append
+ (numbers->string (list wid slope thick))
+ " draw_repeat_slash"))
-;; two beziers with round endings
-(define (bezier-ending z0 z1 z2)
- (let ((x0 (car z0))
- (y0 (cdr z0))
- (x1 (car z1))
- (y1 (cdr z1))
- (x2 (car z2))
- (y2 (cdr z2)))
- (string-append " "
- (numbers->string
- (list x0 y0
- (/ (sqrt (+ (* (- x1 x2) (- x1 x2)) (* (- y1 y2) (- y1 y2)))) 2)))
- " draw_dot")))
-
- ; TODO: use HEIGHT argument
+(define (roundfilledbox x y width height blotdiam)
+ (string-append
+ " "
+ (numbers->string
+ (list x y width height blotdiam)) " draw_round_box"))
+;; TODO: use HEIGHT argument
(define (start-system width height)
- (string-append "\n" (ly:number->string height)
- " start-system\n"
- "{\n"
- "set-ps-scale-to-lily-scale"))
+ (string-append
+ "\n" (ly:number->string height)
+ " start-system\n"
+ "{\n"
+ "set-ps-scale-to-lily-scale"))
(define (stem breapth width depth height)
- (string-append (numbers->string (list breapth width depth height))
- " draw_box" ))
-
-(define (stop-system)
- "}\nstop-system\n")
+ (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 "))
-
+ (string-append "(" s ") show "))
(define (unknown)
"\n unknown\n")
-(define (ez-ball ch letter-col ball-col)
- (string-append
- " (" ch ") "
- (numbers->string (list letter-col ball-col))
- " /Helvetica-Bold " ;; ugh
- " draw_ez_ball"))
-
-(define (define-origin a b c ) "")
-(define (no-origin) "")
-
-
projects / lilypond.git / commitdiff