+ (apply entity 'text expr (reverse! alist))))
+
+(define (dump-path path scale . rest)
+ (define alist '())
+ (define (set-attribute attr val)
+ (set! alist (assoc-set! alist attr val)))
+ (if (not (null? rest))
+ (let* ((dx (car rest))
+ (dy (cadr rest))
+ (total-x (+ dx next-horiz-adv)))
+ (if (or (not (zero? total-x))
+ (not (zero? dy)))
+ (let ((x (ly:format "~4f" total-x))
+ (y (ly:format "~4f" dy)))
+ (set-attribute 'transform
+ (string-append
+ "translate(" x ", " y ") "
+ "scale(" scale ", -" scale ")")))
+ (set-attribute 'transform
+ (string-append
+ "scale(" scale ", -" scale ")"))))
+ (set-attribute 'transform (string-append
+ "scale(" scale ", -" scale ")")))
+
+ (set-attribute 'd path)
+ (set-attribute 'fill "currentColor")
+ (apply entity 'path "" (reverse alist)))
+
+
+;; A global variable for keeping track of the *cumulative*
+;; horizontal advance for glyph strings, but only if there
+;; is more than one glyph.
+(define next-horiz-adv 0.0)
+
+;; Matches the required "unicode" attribute from <glyph>
+(define glyph-unicode-value-regexp
+ (make-regexp "unicode=\"([^\"]+)\""))
+
+;; Matches the optional path data from <glyph>
+(define glyph-path-regexp
+ (make-regexp "d=\"([-MmZzLlHhVvCcSsQqTt0-9.\n ]*)\""))
+
+;; Matches a complete <glyph> element with the glyph-name
+;; attribute value of NAME. For example:
+;;
+;; <glyph glyph-name="period" unicode="." horiz-adv-x="110"
+;; d="M0 55c0 30 25 55 55 55s55 -25 55
+;; -55s-25 -55 -55 -55s-55 25 -55 55z" />
+;;
+;; TODO: it would be better to use an XML library to extract
+;; the glyphs instead, and store them in a hash table. --pmccarty
+;;
+(define (glyph-element-regexp name)
+ (make-regexp (string-append "<glyph"
+ "(([[:space:]]+[-a-z]+=\"[^\"]*\")+)?"
+ "[[:space:]]+glyph-name=\"("
+ name
+ ")\""
+ "(([[:space:]]+[-a-z]+=\"[^\"]*\")+)?"
+ "([[:space:]]+)?"
+ "/>")))
+
+(define (extract-glyph all-glyphs name size . rest)
+ (let* ((new-name (regexp-quote name))
+ (regexp (regexp-exec (glyph-element-regexp new-name) all-glyphs))
+ (glyph (match:substring regexp))
+ (unicode-attr (regexp-exec glyph-unicode-value-regexp glyph))
+ (unicode-attr-value (match:substring unicode-attr 1))
+ (unicode-attr? (regexp-match? unicode-attr))
+ (d-attr (regexp-exec glyph-path-regexp glyph))
+ (d-attr-value "")
+ (d-attr? (regexp-match? d-attr))
+ ;; TODO: not urgent, but do not hardcode this value
+ (units-per-em 1000)
+ (font-scale (ly:format "~4f" (/ size units-per-em)))
+ (path ""))
+
+ (if (and unicode-attr? (not unicode-attr-value))
+ (ly:warning (_ "Glyph must have a unicode value")))
+
+ (if d-attr? (set! d-attr-value (match:substring d-attr 1)))
+
+ (cond (
+ ;; Glyph-strings with path data
+ (and d-attr? (not (null? rest)))
+ (begin
+ (set! path (apply dump-path d-attr-value
+ font-scale
+ (list (cadr rest) (caddr rest))))
+ (set! next-horiz-adv (+ next-horiz-adv
+ (car rest)))
+ path))
+ ;; Glyph-strings without path data ("space")
+ ((and (not d-attr?) (not (null? rest)))
+ (begin
+ (set! next-horiz-adv (+ next-horiz-adv
+ (car rest)))
+ ""))
+ ;; Font smobs with path data
+ ((and d-attr? (null? rest))
+ (set! path (dump-path d-attr-value font-scale))
+ path)
+ ;; Font smobs without path data ("space")
+ (else
+ ""))))
+
+(define (extract-glyph-info all-glyphs glyph size)
+ (let* ((offsets (list-head glyph 3))
+ (glyph-name (car (reverse glyph))))
+ (apply extract-glyph all-glyphs glyph-name size offsets)))
+
+(define (svg-defs svg-font)
+ (let ((start (string-contains svg-font "<defs>"))
+ (end (string-contains svg-font "</defs>")))
+ (substring svg-font (+ start 7) (- end 1))))
+
+(define (cache-font svg-font size glyph)
+ (let ((all-glyphs (svg-defs (cached-file-contents svg-font))))
+ (if (list? glyph)
+ (extract-glyph-info all-glyphs glyph size)
+ (extract-glyph all-glyphs glyph size))))
+
+
+(define (music-string-to-path font size glyph)
+ (let* ((name-style (font-name-style font))
+ (scaled-size (/ size lily-unit-length))
+ (font-file (ly:find-file (string-append name-style ".svg"))))
+
+ (if font-file
+ (cache-font font-file scaled-size glyph)
+ (ly:warning (_ "cannot find SVG font ~S") font-file))))
+
+
+(define (font-smob-to-path font glyph)
+ (let* ((name-style (font-name-style font))
+ (scaled-size (modified-font-metric-font-scaling font))
+ (font-file (ly:find-file (string-append name-style ".svg"))))
+
+ (if font-file
+ (cache-font font-file scaled-size glyph)
+ (ly:warning (_ "cannot find SVG font ~S") font-file))))
+
+(define (woff-font-smob-to-text font expr)
+ (let* ((name-style (font-name-style font))
+ (scaled-size (modified-font-metric-font-scaling font))
+ (font-file (ly:find-file (string-append name-style ".woff")))
+ (charcode (ly:font-glyph-name-to-charcode font expr))
+ (char-lookup (format #f "&#~S;" charcode))
+ (glyph-by-name (eoc 'altglyph `(glyphname . ,expr)))
+ (apparently-broken
+ (comment "FIXME: how to select glyph by name, altglyph is broken?"))
+ (text (string-regexp-substitute "\n" ""
+ (string-append glyph-by-name apparently-broken char-lookup))))
+ (define alist '())
+ (define (set-attribute attr val)
+ (set! alist (assoc-set! alist attr val)))
+ (set-attribute 'font-family name-style)
+ (set-attribute 'font-size scaled-size)
+ (apply entity 'text text (reverse! alist))))
+
+(define font-smob-to-text
+ (if (not (ly:get-option 'svg-woff))
+ font-smob-to-path woff-font-smob-to-text))