Merge branch 'lilypond/translation' of ssh://git.sv.gnu.org/srv/git/lilypond into...

[lilypond.git] / scm / output-svg.scm

diff --git a/scm/output-svg.scm b/scm/output-svg.scm
index 3d76a482d73c2acf24768d02003b37528d529f7d..c916067bdfa38986141752fb193873d6af62e54f 100644 (file)
--- a/scm/output-svg.scm
+++ b/scm/output-svg.scm
@@ -1,21 +1,17 @@
-;;;; output-svg.scm -- implement Scheme output routines for SVG1
+;;;; output-svg.scm -- implement Scheme output routines for SVG
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;;
 ;;;; (c) 2002--2009 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;;                Patrick McCarty <pnorcks@gmail.com>
 
-;;;; http://www.w3.org/TR/SVG11
-;;;; http://www.w3.org/TR/SVG12/ -- page, pageSet in draft
+;;;; Recommendations:
+;;;; http://www.w3.org/TR/SVG11/
+;;;; http://www.w3.org/TR/SVGTiny12/
+;;;; http://www.w3.org/TR/SVGPrint/ -- page, pageSet in draft
 
 ;;;; TODO:
-;;;;  * .cff MUST NOT be in fc's fontpath.
-;;;;    - workaround: remove mf/out from ~/.fonts.conf,
-;;;;      instead add ~/.fonts and symlink all /mf/out/*otf there.
-;;;;    - bug in fontconfig/freetype/pango?
-
 ;;;;  * inkscape page/pageSet support
-;;;;  * inkscape SVG-font support
-;;;;    - use fontconfig/fc-cache for now, see output-gnome.scm
 
 (define-module (scm output-svg))
 (define this-module (current-module))
@@ -37,7 +33,6 @@
   (let ((keyword (car expr)))
     (cond
      ((eq? keyword 'some-func) "")
-     ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
      (else
       (if (module-defined? this-module keyword)
          (apply (eval keyword this-module) (cdr expr))
@@ -75,7 +70,7 @@
   (if (equal? string "")
       (apply eoc entity attributes-alist)
       (string-append
-       (apply eo (cons entity attributes-alist)) string (ec entity))))
+       (apply eo (cons entity attributes-alist)) string (ec entity))))
 
 (define (offset->point o)
   (ly:format "~4f ~4f" (car o) (- (cdr o))))
@@ -84,7 +79,7 @@
   (define (helper lst)
     (if (null? lst)
        '()
-       (cons (format "~S,~S" (car lst) (cadr lst))
+       (cons (format "~S ~S" (car lst) (- (cadr lst)))
              (helper (cddr lst)))))
 
   (string-join (helper lst) " "))
@@ -313,8 +308,7 @@
            '(fill . "currentColor")
            `(stroke-width . ,thick)
            `(d . ,(string-append (svg-bezier first #f)
-                                 (svg-bezier second #t)))
-           )))
+                                 (svg-bezier second #t))))))
 
 (define (char font i)
   (dispatch
@@ -331,7 +325,8 @@
    `(r . ,radius)))
 
 (define (dashed-line thick on off dx dy phase)
-  (draw-line thick 0 0 dx dy `(style . ,(format "stroke-dasharray:~a,~a;" on off))))
+  (draw-line thick 0 0 dx dy
+            `(stroke-dasharray . ,(format "~a,~a" on off))))
 
 (define (draw-line thick x1 y1 x2 y2 . alist)
   (apply entity 'line ""
@@ -397,7 +392,7 @@
      `(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"
+     `(d . ,(ly:format "M~4f ~4fC~4f ~4f ~4f ~4f ~4f ~4fS~4f ~4f ~4f ~4fz"
                x-max 0
                x-max y-max
                x-min y-max
@@ -409,26 +404,26 @@
   (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)
-                       )
+         ((head (car exps))
+          (rest (cdr exps))
+          (arity
+            (cond ((memq head '(rmoveto rlineto lineto moveto)) 2)
+                  ((memq head '(rcurveto curveto)) 6)
+                  ((eq? head 'closepath) 0)
+                  (else 1)))
+          (args (take rest arity))
+          (svg-head (assoc-get head
+                               '((rmoveto . m)
+                                 (rcurveto . c)
+                                 (curveto . C)
+                                 (moveto . M)
+                                 (lineto . L)
+                                 (rlineto . l)
+                                 (closepath . z))
+                               "")))
+
+         (cons (format "~a~a"
+                       svg-head (number-list->point args))
                (convert-path-exps (drop rest arity))))
        '()))
 
@@ -438,7 +433,7 @@
          '(stroke-linecap . "round")
          '(stroke . "currentColor")
          '(fill . "none")
-         `(d . ,(string-join (convert-path-exps commands) " "))))
+         `(d . ,(apply string-append (convert-path-exps commands)))))
 
 (define (placebox x y expr)
   (if (string-null? expr)
@@ -471,8 +466,18 @@
    `(fill . ,(if is-filled "currentColor" "none"))
    '(stroke . "currentColor")
    `(points . ,(string-join
-               (map offset->point (ly:list->offsets '() coords))))
-   ))
+               (map offset->point (ly:list->offsets '() coords))))))
+
+(define (repeat-slash width slope thickness)
+  (define (euclidean-length x y)
+    (sqrt (+ (* x x) (* y y))))
+  (let* ((x-width (euclidean-length thickness (/ thickness slope)))
+        (height (* width slope)))
+    (entity
+      'path ""
+      '(fill . "currentColor")
+      `(d . ,(ly:format "M0 0l~4f 0 ~4f ~4f ~4f 0z"
+                       x-width width (- height) (- x-width))))))
 
 (define (resetcolor)
   "</g>\n")
@@ -495,20 +500,16 @@
          `(width . ,(+ breapth width))
          `(height . ,(+ depth height))
          `(ry . ,(/ blot-diameter 2))
-         '(fill . "currentColor")
-         ))
+         '(fill . "currentColor")))
 
 (define (setcolor r g b)
-  (format "<g color=\"rgb(~a%,~a%,~a%)\">\n"
-         (* 100 r) (* 100 g) (* 100 b)
-         ))
+  (format "<g color=\"rgb(~a%, ~a%, ~a%)\">\n"
+         (* 100 r) (* 100 g) (* 100 b)))
 
 ;; rotate around given point
 (define (setrotation ang x y)
-  (format "<g transform=\"rotate(~a,~a,~a)\">\n"
-    (number->string (* -1 ang))
-    (number->string x)
-    (number->string (* -1 y))))
+  (ly:format "<g transform=\"rotate(~4f, ~4f, ~4f)\">\n"
+            (- ang) x (- y)))
 
 (define (text font string)
   (dispatch `(fontify ,font ,(entity 'tspan (string->entities string)))))