X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-svg.scm;h=b0bf088b3697fb2867bd267a5fdd2852e9a1554b;hb=8f5cd22af76fcb5c77853a5ede8b94ebef97caef;hp=0b0ec7e66bad31fdd10baa3abedf9d6f34426be2;hpb=260073be07f49a5f6f3be8df2af52873843eec60;p=lilypond.git diff --git a/scm/output-svg.scm b/scm/output-svg.scm index 0b0ec7e66b..b0bf088b36 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--2005 Jan Nieuwenhuizen +;;;; (c) 2002--2006 Jan Nieuwenhuizen ;;;; http://www.w3.org/TR/SVG11 ;;;; http://www.w3.org/TR/SVG12/ -- page, pageSet in draft @@ -24,6 +24,7 @@ (guile) (ice-9 regex) (lily) + (srfi srfi-1) (srfi srfi-13)) @@ -70,6 +71,16 @@ (define (offset->point o) (format #f " ~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))) (c123 (list-head lst 3))) @@ -94,10 +105,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 +129,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) @@ -185,64 +196,6 @@ "") -(define (rect-beam width slope thick blot-diameter) - (let* ((x width) - (y (* slope width)) - (z (/ y x))) - (entity 'rect "" - ;; The stroke will stick out. To use stroke, - ;; the stroke-width must be subtracted from all other dimensions. - ;;'(stroke-linejoin . "round") - ;;'(stroke-linecap . "round") - ;;`(stroke-width . ,blot-diameter) - ;;'(stroke . "red") - ;;'(fill . "orange") - - `(x . 0) - `(y . ,(- (/ thick 2))) - `(width . ,width) - `(height . ,(+ thick (* (abs z) (/ thick 2)))) - `(rx . ,(/ blot-diameter 2)) - `(transform . ,(format #f "matrix (1, ~f, 0, 1, 0, 0)" z) - )))) - -(define (beam width slope thick blot-diameter) - (let* ((b blot-diameter) - (t (- thick b)) - (w (- width b)) - (h (* w slope))) - (entity 'polygon "" - '(stroke-linejoin . "round") - '(stroke-linecap . "round") - `(stroke-width . ,blot-diameter) - '(stroke . "currentColor") - '(fill . "currentColor") - `(points . ,(string-join - (map offset->point - (list (cons (/ b 2) (/ t 2)) - (cons (+ w (/ b 2)) (+ h (/ t 2))) - (cons (+ w (/ b 2)) (+ h (- (/ t 2)))) - (cons (/ b 2) (- (/ t 2))))))) - ))) - -(define (path-beam width slope thick blot-diameter) - (let* ((b blot-diameter) - (t (- thick b)) - (w (- width b)) - (h (* w slope))) - (entity 'path "" - '(stroke-linejoin . "round") - '(stroke-linecap . "round") - `(stroke-width . ,blot-diameter) - '(stroke . "currentColor") - '(fill . "currentColor") - `(d . ,(format #f "M ~S,~S l ~S,~S l ~S,~S l ~S,~S l ~S,~S" - (/ b 2) (/ t 2) - w (- h) - 0 (- t) - (- w) h - 0 t)) - ))) (define (bezier-sandwich lst thick) (let* ((first (list-tail lst 4)) @@ -251,13 +204,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)))))) @@ -279,7 +267,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) @@ -290,10 +278,10 @@ (define (placebox x y expr) (entity 'g - ;; FIXME -- JCN - ;;(dispatch expr) expr - `(transform . ,(format #f "translate (~f, ~f)" + ;; 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)" x (- y))))) (define (polygon coords blot-diameter is-filled) @@ -308,6 +296,16 @@ (map offset->point (ly:list->offsets '() coords)))) )) +;; rotate around given point +(define (setrotation ang x y) + (format "" + (number->string (* -1 ang)) + (number->string x) + (number->string (* -1 y)))) + +(define (resetrotation ang x y) + "") + (define (round-filled-box breapth width depth height blot-diameter) (entity 'rect "" ;; The stroke will stick out. To use stroke, @@ -338,7 +336,7 @@ (define (text font string) (dispatch `(fontify ,font ,(entity 'tspan (string->entities string))))) -(define (utf8-string pango-font-description string) +(define (utf-8-string pango-font-description string) (dispatch `(fontify ,pango-font-description ,(entity 'tspan string))))