;;;; source file of the GNU LilyPond music typesetter
;;;;
;;;; (c) 1998--2006 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
+;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
;;;; Note: currently misused as testbed for titles with markup, see
;;;; input/test/title-markup.ly
polygon
repeat-slash
resetcolor
- resetrotatino
+ resetrotation
round-filled-box
setcolor
- setrotation
+ setrotation
text
zigzag-line))
;;;
+;; ice-9 format uses a lot of memory
+;; using simple-format almost halves lilypond cell usage
+(define format simple-format)
+
(define (escape-parentheses s)
(regexp-substitute/global #f "(^|[^\\])([\\(\\)])" s 'pre 1 "\\" 2 'post))
-(define (ps-encoding text)
- (escape-parentheses text))
-
-(define (round2 num)
- (/ (round (* 100 num)) 100))
-
-(define (round4 num)
- (/ (round (* 10000 num)) 10000))
-
(define (str4 num)
- (format #f "~f" (round4 num)))
+ (if (or (nan? num) (inf? num))
+ (begin
+ (ly:warning (_ "Found infinity or nan in output. Substituting 0.0"))
+ (if (ly:get-option 'strict-infinity-checking)
+ (exit 1))
+ "0.0")
+ (ly:number->string num)))
(define (number-pair->string4 numpair)
- (format #f "~f ~f" (round4 (car numpair)) (round4 (cdr numpair))))
+ (string-append (str4 (car numpair))
+ " "
+ (str4 (cdr numpair))))
(define (numbers->string4 numlist)
(string-join (map str4 numlist) " "))
(define (circle radius thick fill)
(format #f
- "~a ~f ~f draw_circle"
+ "~a ~a ~a draw_circle"
(if fill
"true"
"false")
- (round4 radius) (round4 thick)))
+ (str4 radius) (str4 thick)))
-(define (dashed-line thick on off dx dy)
- (format #f "~a ~a ~a [ ~a ~a ] 0 draw_dashed_line"
+(define (dashed-line thick on off dx dy phase)
+ (format #f "~a ~a ~a [ ~a ~a ] ~a draw_dashed_line"
(str4 dx)
(str4 dy)
(str4 thick)
(str4 on)
- (str4 off)))
+ (str4 off)
+ (str4 phase)
+
+ ))
;; what the heck is this interface ?
(define (dashed-slur thick on off l)
(define (glyph-spec w x y g)
(let ((prefix (if (string? g) "/" "")))
- (format #f "~f ~f ~a~a"
- (round2 (+ w x))
- (round2 y)
+ (format #f "~a ~a ~a~a"
+ (str4 (+ w x))
+ (str4 y)
prefix g)))
(format #f
(define (grob-cause offset grob)
(let* ((cause (ly:grob-property grob 'cause))
- (music-origin (if (ly:music? cause)
- (ly:music-property cause 'origin))))
+ (music-origin (if (ly:stream-event? cause)
+ (ly:event-property cause 'origin))))
(if (not (ly:input-location? music-origin))
""
(let* ((location (ly:input-file-line-char-column music-origin))
(if (and (< 0 (interval-length x-ext))
(< 0 (interval-length y-ext)))
- (format #f "~$ ~$ ~$ ~$ (textedit://~a:~a:~a:~a) mark_URI\n"
- (+ (car offset) (car x-ext))
- (+ (cdr offset) (car y-ext))
- (+ (car offset) (cdr x-ext))
- (+ (cdr offset) (cdr y-ext))
+ (format #f "~a ~a ~a ~a (textedit://~a:~a:~a:~a) mark_URI\n"
+ (str4 (+ (car offset) (car x-ext)))
+ (str4 (+ (cdr offset) (car y-ext)))
+ (str4 (+ (car offset) (cdr x-ext)))
+ (str4 (+ (cdr offset) (cdr y-ext)))
;; TODO
;;full escaping.
;; backslash is interpreted by GS.
- (string-regexp-substitute "\\\\" "/"
- (string-regexp-substitute " " "%20" file))
+ (ly:string-substitute "\\" "/"
+ (ly:string-substitute " " "%20" file))
(cadr location)
(caddr location)
(cadddr location))
(define (euclidean-length x y)
(sqrt (+ (* x x) (* y y))))
- (let ((x-width (euclidean-length slope (/ beam-thickness slope)))
+ (let ((x-width (euclidean-length beam-thickness (/ beam-thickness slope)))
(height (* width slope)))
(format #f "~a draw_repeat_slash"
(numbers->string4 (list x-width width height)))))
-;; restore color from stack
-(define (resetcolor) "setrgbcolor\n")
-
-;; reset rotation
-(define (resetrotation ang x y)
- (format "~a translate ~a rotate ~a translate\n"
- (numbers->string4 (list x y))
- (number->string (* -1 ang))
- (numbers->string4 (list (* -1 x) (* -1 y)))))
(define (round-filled-box left right bottom top blotdiam)
(let* ((halfblot (/ blotdiam 2))
;; save current color on stack and set new color
(define (setcolor r g b)
- (format #f "currentrgbcolor ~a setrgbcolor\n"
+ (format #f "gsave ~a setrgbcolor\n"
(numbers->string4 (list r g b))))
+;; restore color from stack
+(define (resetcolor) "grestore \n")
+
;; rotation around given point
(define (setrotation ang x y)
- (format "~a translate ~a rotate ~a translate\n"
+ (format #f "gsave ~a translate ~a rotate ~a translate\n"
(numbers->string4 (list x y))
(number->string ang)
(numbers->string4 (list (* -1 x) (* -1 y)))))
+(define (resetrotation ang x y)
+ "grestore ")
+
+
(define (text font s)
;; (ly:warning (_ "TEXT backend-command encountered in Pango backend"))
;; (ly:warning (_ "Arguments: ~a ~a"" font str))
"\n unknown\n")
(define (url-link url x y)
- (format #f "~$ ~$ ~$ ~$ (~a) mark_URI"
+ (format #f "~a ~a ~a ~a (~a) mark_URI"
(car x)
(car y)
(cdr x)
(str4 thick)
(str4 dx)
(str4 dy)))
+
+
+(define (path thickness exps)
+ (define (convert-path-exps exps)
+ (if (pair? exps)
+ (let*
+ ((head (car exps))
+ (rest (cdr exps))
+ (arity
+ (cond
+ ((memq head '(rmoveto rlineto lineto moveto)) 2)
+ ((memq head '(rcurveto curveto)) 6)
+ (else 1)))
+ (args (take rest arity))
+ )
+
+ ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here.
+ (cons (format #f
+ "~a ~a "
+ (string-join (map (lambda (x) (format #f "~a " x)) args) " ")
+ head)
+ (convert-path-exps (drop rest arity))))
+ '()))
+
+
+ (format #f
+ "1 setlinecap ~a setlinewidth\n~a stroke"
+ thickness
+ (string-join (convert-path-exps exps) " ")))
+
projects / lilypond.git / blobdiff