X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-svg.scm;h=b6bdb2721c56abc52ee406bf07c4a4bb900e2ec5;hb=5b4b0d6e9a197e8f9eb085b7c2ad78b8be3e5cfc;hp=786a37ca177deb434518e3b5e2d650053dba97bd;hpb=68d7330f72a14a8df49c49ed1566179248096092;p=lilypond.git diff --git a/scm/output-svg.scm b/scm/output-svg.scm index 786a37ca17..b6bdb2721c 100644 --- a/scm/output-svg.scm +++ b/scm/output-svg.scm @@ -2,7 +2,7 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2002--2006 Jan Nieuwenhuizen +;;;; (c) 2002--2008 Jan Nieuwenhuizen ;;;; http://www.w3.org/TR/SVG11 ;;;; http://www.w3.org/TR/SVG12/ -- page, pageSet in draft @@ -23,9 +23,13 @@ (use-modules (guile) (ice-9 regex) + (ice-9 format) (lily) + (srfi srfi-1) (srfi srfi-13)) +(define fancy-format format) +(define format ergonomic-simple-format) (define lily-unit-length 1.75) @@ -44,20 +48,20 @@ ;; Helper functions (define-public (attributes attributes-alist) (apply string-append - (map (lambda (x) (format #f " ~s=\"~a\"" (car x) (cdr x))) + (map (lambda (x) (format " ~s=\"~a\"" (car x) (cdr x))) attributes-alist))) (define-public (eo entity . attributes-alist) "o = open" - (format #f "<~S~a>\n" entity (attributes attributes-alist))) + (format "<~S~a>\n" entity (attributes attributes-alist))) (define-public (eoc entity . attributes-alist) " oc = open/close" - (format #f "<~S~a/>\n" entity (attributes attributes-alist))) + (format "<~S~a/>\n" entity (attributes attributes-alist))) (define-public (ec entity) "c = close" - (format #f "\n" entity)) + (format "\n" entity)) @@ -68,7 +72,17 @@ (apply eo (cons entity attributes-alist)) string (ec entity)))) (define (offset->point o) - (format #f " ~S,~S" (car o) (- (cdr o)))) + (format " ~S,~S" (car o) (- (cdr o)))) + +(define (number-list->point lst) + (define (helper lst) + (if (null? lst) + '() + (cons (format "~S,~S" (car lst) (cadr lst)) + (helper (cddr lst))))) + + (string-join (helper lst) " ")) + (define (svg-bezier lst close) (let* ((c0 (car (list-tail lst 3))) @@ -84,7 +98,7 @@ (* x x)) (define (integer->entity integer) - (format #f "&#x~x;" integer)) + (fancy-format "&#x~x;" integer)) (define (char->entity char) (integer->entity (char->integer char))) @@ -94,10 +108,10 @@ (map (lambda (x) (char->entity x)) (string->list string)))) (define pango-description-regexp-comma - (make-regexp "^([^,]+), ?([-a-zA-Z_]*) ([0-9.]+)$")) + (make-regexp "([^,]+), ?([-a-zA-Z_]*) ([0-9.]+)$")) (define pango-description-regexp-nocomma - (make-regexp "^([^ ]+) ([-a-zA-Z_]*) ?([0-9.]+)$")) + (make-regexp "([^ ]+) ([-a-zA-Z_]*) ?([0-9.]+)$")) (define (pango-description-to-svg-font str) (let* @@ -118,7 +132,7 @@ (set! size (string->number (match:substring match 3)))) - (ly:warning (_ "can't decypher Pango description: ~a") str)) + (ly:warning (_ "cannot decypher Pango description: ~a") str)) (set! style (if (string? style) @@ -139,7 +153,7 @@ (size (modified-font-metric-font-scaling font)) (anchor "west")) - (format #f "font-family:~a;font-style:~a;font-size:~a;text-anchor:~a;" + (format "font-family:~a;font-style:~a;font-size:~a;text-anchor:~a;" (car name-style) (cadr name-style) size anchor)))) @@ -193,13 +207,48 @@ (entity 'path "" '(stroke-linejoin . "round") '(stroke-linecap . "round") - `(stroke-width . ,thick) '(stroke . "currentColor") '(fill . "currentColor") + `(stroke-width . ,thick) `(d . ,(string-append (svg-bezier first #f) (svg-bezier second first-c0))) ))) +(define (path thick commands) + (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)) + (svg-head (assoc-get head '((rmoveto . m) + (rcurveto . c) + (curveto . C) + (moveto . M) + (lineto . L) + (rlineto . l)) + "")) + ) + + (cons (format "~a~a " + svg-head (number-list->point args) + ) + (convert-path-exps (drop rest arity)))) + '())) + + (entity 'path "" + `(stroke-width . ,thick) + '(stroke-linejoin . "round") + '(stroke-linecap . "round") + '(stroke . "currentColor") + '(fill . "none") + `(d . ,(string-join (convert-path-exps commands) " ")))) + (define (char font i) (dispatch `(fontify ,font ,(entity 'tspan (char->entity (integer->char i)))))) @@ -221,7 +270,7 @@ (y2 . ,(- y2))) alist))) -(define (dashed-line thick on off dx dy) +(define (dashed-line thick on off dx dy phase) (draw-line thick 0 0 dx dy `(style . ,(format "stroke-dasharray:~a,~a;" on off)))) (define (named-glyph font name) @@ -235,7 +284,7 @@ expr ;; FIXME: Not using GNU coding standards [translate ()] here ;; to work around a bug in Microsoft Internet Explorer 6.0 - `(transform . ,(format #f "translate(~f, ~f)" + `(transform . ,(ly:format "translate(~f, ~f)" x (- y))))) (define (polygon coords blot-diameter is-filled) @@ -287,6 +336,37 @@ `(stroke-width . ,thick) `(r . ,radius))) +(define (ellipse x-radius y-radius thick is-filled) + (entity + 'ellipse "" + '(stroke-linejoin . "round") + '(stroke-linecap . "round") + `(fill . ,(if is-filled "currentColor" "none")) + `(stroke . "currentColor") + `(stroke-width . ,thick) + `(rx . ,x-radius) + `(ry . ,y-radius))) + +(define (oval x-radius y-radius thick is-filled) + (let ((x-max x-radius) + (x-min (- x-radius)) + (y-max y-radius) + (y-min (- y-radius))) + (entity + 'path "" + '(stroke-linejoin . "round") + '(stroke-linecap . "round") + `(fill . ,(if is-filled "currentColor" "none")) + `(stroke . "currentColor") + `(stroke-width . ,thick) + `(d . ,(ly:format "M~4f,~4f C~4f,~4f ~4f,~4f ~4f,~4f S~4f,~4f ~4f,~4f" + x-max 0 + x-max y-max + x-min y-max + x-min 0 + x-max y-min + x-max 0))))) + (define (text font string) (dispatch `(fontify ,font ,(entity 'tspan (string->entities string)))))