Midi2ly: grok midi files with up to 256 tracks, was 32. Fixes #1479.

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

diff --git a/scm/output-svg.scm b/scm/output-svg.scm
index 4c421006986e1433e641d239a0ee406e01d2e6e7..0a60cf4ffd74d724780a26cae91da6dcb780ea82 100644 (file)
--- a/scm/output-svg.scm
+++ b/scm/output-svg.scm
@@ -1,6 +1,6 @@
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
-;;;; Copyright (C) 2002--2010 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Copyright (C) 2002--2011 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;;                Patrick McCarty <pnorcks@gmail.com>
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
@@ -29,6 +29,7 @@
   (guile)
   (ice-9 regex)
   (ice-9 format)
+  (ice-9 optargs)
   (lily)
   (srfi srfi-1)
   (srfi srfi-13))
@@ -376,6 +377,60 @@
     `(rx . ,x-radius)
     `(ry . ,y-radius)))
 
+(define (partial-ellipse x-radius y-radius start-angle end-angle thick connect fill)
+  (define (make-ellipse-radius x-radius y-radius angle)
+    (/ (* x-radius y-radius)
+       (sqrt (+ (* (* y-radius y-radius)
+                   (* (cos angle) (cos angle)))
+                (* (* x-radius x-radius)
+                   (* (sin angle) (sin angle)))))))
+  (let*
+    ((new-start-angle (* PI-OVER-180 (angle-0-360 start-angle)))
+     (start-radius (make-ellipse-radius x-radius y-radius new-start-angle))
+     (new-end-angle (* PI-OVER-180 (angle-0-360 end-angle)))
+     (end-radius (make-ellipse-radius x-radius y-radius new-end-angle))
+     (epsilon 1.5e-3)
+     (x-end (- (* end-radius (cos new-end-angle))
+               (* start-radius (cos new-start-angle))))
+     (y-end (- (* end-radius (sin new-end-angle))
+               (* start-radius (sin new-start-angle)))))
+   (if (and (< (abs x-end) epsilon) (< (abs y-end) epsilon))
+    (entity
+      'ellipse ""
+      `(fill . ,(if fill "currentColor" "none"))
+      `(stroke . "currentColor")
+      `(stroke-width . ,thick)
+      '(stroke-linejoin . "round")
+      '(stroke-linecap . "round")
+      '(cx . 0)
+      '(cy . 0)
+      `(rx . ,x-radius)
+      `(ry . ,y-radius))
+    (entity
+      'path ""
+      `(fill . ,(if fill "currentColor" "none"))
+      `(stroke . "currentColor")
+      `(stroke-width . ,thick)
+      '(stroke-linejoin . "round")
+      '(stroke-linecap . "round")
+      (cons
+        'd
+        (string-append
+          (ly:format
+            "M~4f ~4fA~4f ~4f 0 ~4f 0 ~4f ~4f"
+            (* start-radius (cos new-start-angle))
+            (- (* start-radius (sin new-start-angle)))
+            x-radius
+            y-radius
+            (if (> 0 (- new-start-angle new-end-angle)) 0 1)
+            (* end-radius (cos new-end-angle))
+            (- (* end-radius (sin new-end-angle))))
+            (if connect
+                (ly:format "L~4f,~4f"
+                           (* start-radius (cos new-start-angle))
+                           (- (* start-radius (sin new-start-angle))))
+                "")))))))
+
 (define (embedded-svg string)
   string)
 
@@ -462,7 +517,7 @@
                        x-max y-min
                        x-max 0)))))
 
-(define (path thick commands)
+(define* (path thick commands #:optional (cap 'round) (join 'round) (fill? #f))
   (define (convert-path-exps exps)
     (if (pair? exps)
        (let*
@@ -488,13 +543,27 @@
                (convert-path-exps (drop rest arity))))
        '()))
 
-  (entity 'path ""
-         `(stroke-width . ,thick)
-         '(stroke-linejoin . "round")
-         '(stroke-linecap . "round")
-         '(stroke . "currentColor")
-         '(fill . "none")
-         `(d . ,(apply string-append (convert-path-exps commands)))))
+  (let* ((line-cap-styles '(butt round square))
+        (line-join-styles '(miter round bevel))
+        (cap-style (if (not (memv cap line-cap-styles))
+                       (begin
+                         (ly:warning (_ "unknown line-cap-style: ~S")
+                                     (symbol->string cap))
+                         'round)
+                       cap))
+        (join-style (if (not (memv join line-join-styles))
+                        (begin
+                          (ly:warning (_ "unknown line-join-style: ~S")
+                                      (symbol->string join))
+                          'round)
+                        join)))
+    (entity 'path ""
+           `(stroke-width . ,thick)
+           `(stroke-linejoin . ,(symbol->string join-style))
+           `(stroke-linecap . ,(symbol->string cap-style))
+           '(stroke . "currentColor")
+           `(fill . ,(if fill? "currentColor" "none"))
+           `(d . ,(apply string-append (convert-path-exps commands))))))
 
 (define (placebox x y expr)
   (if (string-null? expr)
@@ -546,6 +615,9 @@
 (define (resetrotation ang x y)
   "</g>\n")
 
+(define (resetscale)
+  "</g>\n")
+
 (define (round-filled-box breapth width depth height blot-diameter)
   (entity
     'rect ""
@@ -573,6 +645,10 @@
   (ly:format "<g transform=\"rotate(~4f, ~4f, ~4f)\">\n"
             (- ang) x (- y)))
 
+(define (setscale x y)
+  (ly:format "<g transform=\"scale(~4f, ~4f)\">\n"
+            x y))
+
 (define (text font string)
   (dispatch `(fontify ,font ,(entity 'tspan (string->entities string)))))
 
@@ -590,4 +666,8 @@
    (ec 'a)))
 
 (define (utf-8-string pango-font-description string)
-  (dispatch `(fontify ,pango-font-description ,(entity 'tspan string))))
+  (let ((escaped-string (string-regexp-substitute
+                         "<" "&lt;"
+                         (string-regexp-substitute "&" "&amp;" string))))
+    (dispatch `(fontify ,pango-font-description
+                       ,(entity 'tspan escaped-string)))))