Add '-dcrop' option to ps and svg backends

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

diff --git a/scm/output-svg.scm b/scm/output-svg.scm
index 8e2c532a3b1a67f303a044f25820a83af4e0fe13..653664122cd5d20befb84ed84fa4147ec6690840 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--2012 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Copyright (C) 2002--2015 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;;                Patrick McCarty <pnorcks@gmail.com>
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
@@ -40,14 +40,14 @@
 
 ;; Helper functions
 (define-public (attributes attributes-alist)
-  (apply string-append
-         (map (lambda (x)
-                (let ((attr (car x))
-                      (value (cdr x)))
-                  (if (number? value)
-                      (set! value (ly:format "~4f" value)))
-                  (format #f " ~s=\"~a\"" attr value)))
-              attributes-alist)))
+  (string-concatenate
+   (map (lambda (x)
+          (let ((attr (car x))
+                (value (cdr x)))
+            (if (number? value)
+                (set! value (ly:format "~4f" value)))
+            (format #f " ~s=\"~a\"" attr value)))
+        attributes-alist)))
 
 (define-public (eo entity . attributes-alist)
   "o = open"
@@ -61,20 +61,25 @@
   "c = close"
   (format #f "</~S>\n" entity))
 
-(define (start-enclosing-id-node s)
-  (string-append "<g id=\"" s "\">\n"))
+(define (start-group-node attributes)
+  (define attributes-string
+    (string-concatenate
+     (map (lambda (item)
+            (ly:format " ~a=\"~a\"" (car item) (cdr item)))
+       attributes)))
+  (string-append "<g" attributes-string ">\n"))
 
-(define (end-enclosing-id-node)
+(define (end-group-node)
   "</g>\n")
 
 (define-public (comment s)
   (string-append "<!-- " s " -->\n"))
 
 (define-public (entity entity string . attributes-alist)
-  (if (equal? string "")
+  (if (string-null? string)
       (apply eoc entity attributes-alist)
       (string-append
-       (apply eo (cons entity attributes-alist)) string (ec entity))))
+       (apply eo entity attributes-alist) string (ec entity))))
 
 (define (offset->point o)
   (ly:format "~4f ~4f" (car o) (- (cdr o))))
@@ -83,7 +88,7 @@
   (define (helper lst)
     (if (null? lst)
         '()
-        (cons (format #f "~S ~S" (car lst) (- (cadr lst)))
+        (cons (ly:format "~4f ~4f" (car lst) (- (cadr lst)))
               (helper (cddr lst)))))
 
   (string-join (helper lst) " "))
@@ -108,8 +113,8 @@
   (integer->entity (char->integer char)))
 
 (define (string->entities string)
-  (apply string-append
-         (map (lambda (x) (char->entity x)) (string->list string))))
+  (string-concatenate
+   (map char->entity (string->list string))))
 
 (define svg-element-regexp
   (make-regexp "^(<[a-z]+) ?(.*>)"))
@@ -473,13 +478,38 @@
   (if (not (ly:get-option 'svg-woff)) embedded-glyph-string woff-glyph-string))
 
 (define (grob-cause offset grob)
-  "")
+  (and (ly:get-option 'point-and-click)
+       (let* ((cause (ly:grob-property grob 'cause))
+              (music-origin (if (ly:stream-event? cause)
+                                (ly:event-property cause 'origin)))
+              (point-and-click (ly:get-option 'point-and-click)))
+         (and (ly:input-location? music-origin)
+              (cond ((boolean? point-and-click) point-and-click)
+                    ((symbol? point-and-click)
+                     (ly:in-event-class? cause point-and-click))
+                    (else (any (lambda (t)
+                                 (ly:in-event-class? cause t))
+                               point-and-click)))
+              (let* ((location (ly:input-file-line-char-column music-origin))
+                     (raw-file (car location))
+                     (file (if (is-absolute? raw-file)
+                               raw-file
+                               (string-append (ly-getcwd) "/" raw-file))))
+                
+                (ly:format "<a style=\"color:inherit;\" xlink:href=\"textedit://~a:~a:~a:~a\">\n"
+                           ;; Backslashes are not valid
+                           ;; file URI path separators.
+                           (ly:string-percent-encode
+                            (ly:string-substitute "\\" "/" file))
+                           
+                           (cadr location)
+                           (caddr location)
+                           (1+ (cadddr location))))))))
 
 (define (named-glyph font name)
   (fontify font name))
 
-(define (no-origin)
-  "")
+(define (no-origin) "</a>\n")
 
 (define* (path thick commands #:optional (cap 'round) (join 'round) (fill? #f))
   (define (convert-path-exps exps)
@@ -527,7 +557,7 @@
             `(stroke-linecap . ,(symbol->string cap-style))
             '(stroke . "currentColor")
             `(fill . ,(if fill? "currentColor" "none"))
-            `(d . ,(apply string-append (convert-path-exps commands))))))
+            `(d . ,(string-concatenate (convert-path-exps commands))))))
 
 (define (placebox x y expr)
   (if (string-null? expr)
@@ -590,7 +620,7 @@
    '(fill . "currentColor")))
 
 (define (setcolor r g b)
-  (format #f "<g color=\"rgb(~a%, ~a%, ~a%)\">\n"
+  (ly:format "<g color=\"rgb(~4f%, ~4f%, ~4f%)\">\n"
           (* 100 r) (* 100 g) (* 100 b)))
 
 ;; rotate around given point