Re: SVG in \markup Block?

[Aaron Hill]

Took some time to refactor things and add functionality.  I believe I 
have managed to support all SVG path commands, except for elliptic arcs 
(A/a).

This utility function is intended to be used with \path in the following 
manner:

  \markup \path #0.1 \svgPath "M1,2 L-3,4"

Notes:

- I opted against having the utility function invert the Y coordinates.  
If you paste a path description from a real SVG file, it will appear 
upside-down.  You can easily \scale #'(1 . -1) to fix that, as shown in 
the test code at the bottom of the snippet.

- Since LilyPond does not natively support certain path commands, 
several are being emulated with the ones that do exist.  While the 
visual result will match, the actual SVG output will not.  Commands like 
H/h and V/v are converted into L/l.  The tangent-preserving S/s as well 
as the pseudo-quadratics Q/q and T/t are all converted to C/c.

- Though the snippet below lists version 2.19, this code appears to work 
fine in 2.18 after adding parser and location to the two scheme 
functions.  As such, this probably could be submitting to the LSR, which 
I understand has to stay on stable for the time-being.


%%%%
\version "2.19.83"

#(use-modules (ice-9 regex))

svgPath = #(define-scheme-function
  (str) (string?)
  "Converts an SVG-style command list @var{str} to
the format supported by the @code{\\path} markup command."

  ;; Regular expressions for matching strings that
  ;; resemble SVG-style path commands and numbers.
  (define command-regex (make-regexp "([A-Za-z])([ ,.0-9+-]*)"))
  (define number-regex (make-regexp "[+-]?[0-9]+([.][0-9]+)?"))

  ;; Variables to keep track of path details
  ;; to help with emulating SVG commands.
  (define start-point '())
  (define current-point '(0 . 0))
  (define (set-point pt)
    (if (null? start-point) (set! start-point pt))
    (set! current-point pt))
  (define (back-to-start)
    (set! current-point
      (if (null? start-point) '(0 . 0) start-point)))
  (define (reset-start) (set! start-point '()))
  (define (relative-point pt)
    (cons (+ (car current-point) (car pt))
          (+ (cdr current-point) (cdr pt))))
  (define tangent-vector '())
  (define (set-tangent ctlpt endpt)
    (set! tangent-vector
      (cons (- (car endpt) (car ctlpt))
            (- (cdr endpt) (cdr ctlpt)))))
  (define (reset-tangent) (set! tangent-vector '()))
  (define (apply-tangent pt)
    (if (null? tangent-vector) pt
      (cons (+ (car pt) (car tangent-vector))
            (+ (cdr pt) (cdr tangent-vector)))))

  ;; Primary logic for processing each command.
  (define (handle-command sym args)
    (define (take-args len)
      (if (<= len (length args))
        (take args len)
        (ly:error
          "SVG command ~a expects ~a arguments, only ~a provided"
          sym len (length args))))
    (define (coords->points coords)
      (cond ((null? coords) '())
            ((null? (cdr coords))
              (ly:error "Expecting an even number of coordinates."))
            (else (cons
              (cons (first coords) (second coords))
              (coords->points (drop coords 2))))))
    (define (point->coords pt) (list (car pt) (cdr pt)))
    (define (points->coords pts) (apply append (map point->coords pts)))
    (define (take-point) (first (coords->points (take-args 2))))
    (define (take-points count) (coords->points (take-args (* count 
2))))
    (let ((rel? (memq sym '(m l h v c s q t))))
      (case sym
        ((M m)
           (let ((pt (take-point)))
             (reset-start)
             (set-point (if rel? (relative-point pt) pt))
             (cons (if rel? 'rmoveto 'moveto) (point->coords pt))))
        ((L l)
           (let ((pt (take-point)))
             (set-point (if rel? (relative-point pt) pt))
             (cons (if rel? 'rlineto 'lineto) (point->coords pt))))
        ((H h V v)
          (let* ((horiz? (memq sym '(H h)))
                 (coord (first (take-args 1)))
                 (pt (if horiz?
                       (cons coord (if rel? 0 (cdr current-point)))
                       (cons (if rel? 0 (car current-point)) coord))))
            (set-point (if rel? (relative-point pt) pt))
            (cons (if rel? 'rlineto 'lineto) (point->coords pt))))
        ((C c S s)
          (let* ((tangent? (memq sym '(S s)))
                 (pts (take-points (if tangent? 2 3))))
            (if tangent? (set! pts
              (cons (if rel? tangent-vector (apply-tangent 
current-point))
                    pts)))
            (apply set-tangent (take-right pts 2))
            (set-point (if rel? (relative-point (last pts)) (last pts)))
            (cons (if rel? 'rcurveto 'curveto) (points->coords pts))))
        ((Q q T t)
          (let* ((tangent? (memq sym '(T t)))
                 (pts (take-points (if tangent? 1 2))))
            (if tangent? (set! pts
              (cons (if rel? tangent-vector (apply-tangent 
current-point))
                    pts)))
            (set! pts (cons (first pts) pts))
            (apply set-tangent (take-right pts 2))
            (set-point (if rel? (relative-point (last pts)) (last pts)))
            (cons (if rel? 'rcurveto 'curveto) (points->coords pts))))
        ((Z z) (back-to-start) '(closepath))
        (else (ly:error "Unhandled SVG command ~a" sym)))))

  ;; Driver logic for parsing.
  (define (command-match-proc m)
    (let ((sym (string->symbol (match:substring m 1)))
          (args (map (lambda (n) (string->number (match:substring n)))
                     (list-matches number-regex (match:substring m 
2)))))
      (handle-command sym args)))
  (map-in-order
    command-match-proc
    (list-matches command-regex str)))

%% Test code
testSvgPath = #(define-scheme-function (str) (string?) #{
  \markup \left-column {
    \line { \bold Input: \wordwrap-string #str }
    \line { \bold Output:
            \wordwrap-string #(format #f "~a" #{ \svgPath #str #}) }
    \line { \hspace #2 \vcenter \scale #'(1 . -1) \path #0.4 \svgPath 
#str }
    \vspace #0.5
  } #})

\paper { line-width = 8\cm }
\testSvgPath "M1 2 L-3 5 H-1 V2 Z"
\testSvgPath "M0,0v1m1,-1v2m1,-2v3"
\testSvgPath "M -1,5 C 0,4 2,1 0,1 S 0,4 1,5"
\testSvgPath "M 2,3 q 0,3 3,0 m -2,0.5 l 2,-0.5 l -0.5,2 z"
%%%%


-- Aaron Hill

svg-path-string.cropped.png
Description: PNG image