X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-svg.scm;h=0d5dda4e95e19d43cf118f8225b99b40ced64459;hb=7e64dd65645be4f69620ad30d35991318bce6321;hp=3d76a482d73c2acf24768d02003b37528d529f7d;hpb=7ca015f220c21f306e3eeffe640e914828d91bda;p=lilypond.git

diff --git a/scm/output-svg.scm b/scm/output-svg.scm
index 3d76a482d7..0d5dda4e95 100644
--- a/scm/output-svg.scm
+++ b/scm/output-svg.scm
@@ -1,21 +1,9 @@
-;;;; 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>
-
-;;;; http://www.w3.org/TR/SVG11
-;;;; http://www.w3.org/TR/SVG12/ -- 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
+;;;;                Patrick McCarty <pnorcks@gmail.com>
 
 (define-module (scm output-svg))
 (define this-module (current-module))
@@ -35,15 +23,11 @@
 
 (define (dispatch expr)
   (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))
-	  (begin
-	    (ly:warning (_ "undefined: ~S") keyword)
-	    ""))))))
+    (cond ((eq? keyword 'some-func) "")
+	  (else (if (module-defined? this-module keyword)
+		    (apply (eval keyword this-module) (cdr expr))
+		    (begin (ly:warning (_ "undefined: ~S") keyword)
+			   ""))))))
 
 ;; Helper functions
 (define-public (attributes attributes-alist)
@@ -75,7 +59,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 +68,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) " "))
@@ -128,12 +112,9 @@
   (define alist '())
   (define (set-attribute attr val)
     (set! alist (assoc-set! alist attr val)))
-  (let*
-    ((match-1 (regexp-exec pango-description-regexp-comma str))
-     (match-2 (regexp-exec pango-description-regexp-nocomma str))
-     (match (if match-1
-		match-1
-		match-2)))
+  (let* ((match-1 (regexp-exec pango-description-regexp-comma str))
+	 (match-2 (regexp-exec pango-description-regexp-nocomma str))
+	 (match (if match-1 match-1 match-2)))
 
     (if (regexp-match? match)
 	(begin
@@ -313,8 +294,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
@@ -322,40 +302,41 @@
 
 (define (circle radius thick is-filled)
   (entity
-   'circle ""
-   '(stroke-linejoin . "round")
-   '(stroke-linecap . "round")
-   `(fill . ,(if is-filled "currentColor" "none"))
-   `(stroke . "currentColor")
-   `(stroke-width . ,thick)
-   `(r . ,radius)))
+    'circle ""
+    '(stroke-linejoin . "round")
+    '(stroke-linecap . "round")
+    `(fill . ,(if is-filled "currentColor" "none"))
+    `(stroke . "currentColor")
+    `(stroke-width . ,thick)
+    `(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 ""
 	 (append
-	  `((stroke-linejoin . "round")
-	    (stroke-linecap . "round")
-	    (stroke-width . ,thick)
-	    (stroke . "currentColor")
-	    (x1 . ,x1)
-	    (y1 . ,(- y1))
-	    (x2 . ,x2)
-	    (y2 . ,(- y2)))
-	  alist)))
+	   `((stroke-linejoin . "round")
+	     (stroke-linecap . "round")
+	     (stroke-width . ,thick)
+	     (stroke . "currentColor")
+	     (x1 . ,x1)
+	     (y1 . ,(- y1))
+	     (x2 . ,x2)
+	     (y2 . ,(- y2)))
+	   alist)))
 
 (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)))
+    '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 (embedded-svg string)
   string)
@@ -387,48 +368,47 @@
 
 (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)))
+	(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)))))
+      'path ""
+      '(stroke-linejoin . "round")
+      '(stroke-linecap . "round")
+      `(fill . ,(if is-filled "currentColor" "none"))
+      `(stroke . "currentColor")
+      `(stroke-width . ,thick)
+      `(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
+			x-min 0
+			x-max y-min
+			x-max 0)))))
 
 (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)
-			)
+	  ((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 +418,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)
@@ -464,15 +444,25 @@
 
 (define (polygon coords blot-diameter is-filled)
   (entity
-   'polygon ""
-   '(stroke-linejoin . "round")
-   '(stroke-linecap . "round")
-   `(stroke-width . ,blot-diameter)
-   `(fill . ,(if is-filled "currentColor" "none"))
-   '(stroke . "currentColor")
-   `(points . ,(string-join
-		(map offset->point (ly:list->offsets '() coords))))
-   ))
+    'polygon ""
+    '(stroke-linejoin . "round")
+    '(stroke-linecap . "round")
+    `(stroke-width . ,blot-diameter)
+    `(fill . ,(if is-filled "currentColor" "none"))
+    '(stroke . "currentColor")
+    `(points . ,(string-join
+		  (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")
@@ -481,34 +471,31 @@
   "</g>\n")
 
 (define (round-filled-box breapth width depth height blot-diameter)
-  (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)
-	  ;;'(stroke . "red")
-	  ;;'(fill . "orange")
-
-	  `(x . ,(- breapth))
-	  `(y . ,(- height))
-	  `(width . ,(+ breapth width))
-	  `(height . ,(+ depth height))
-	  `(ry . ,(/ blot-diameter 2))
-	  '(fill . "currentColor")
-	  ))
+  (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)
+    ;;'(stroke . "red")
+    ;;'(fill . "orange")
+
+    `(x . ,(- breapth))
+    `(y . ,(- height))
+    `(width . ,(+ breapth width))
+    `(height . ,(+ depth height))
+    `(ry . ,(/ blot-diameter 2))
+    '(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)))))