scm/output-svg.scm

   1 ;;;; output-svg.scm -- implement Scheme output routines for SVG1
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 2002--2009 Jan Nieuwenhuizen <janneke@gnu.org>
   6
   7 ;;;; http://www.w3.org/TR/SVG11
   8 ;;;; http://www.w3.org/TR/SVG12/ -- page, pageSet in draft
   9
  10 ;;;; TODO:
  11 ;;;;  * .cff MUST NOT be in fc's fontpath.
  12 ;;;;    - workaround: remove mf/out from ~/.fonts.conf,
  13 ;;;;      instead add ~/.fonts and symlink all /mf/out/*otf there.
  14 ;;;;    - bug in fontconfig/freetype/pango?
  15
  16 ;;;;  * inkscape page/pageSet support
  17 ;;;;  * inkscape SVG-font support
  18 ;;;;    - use fontconfig/fc-cache for now, see output-gnome.scm
  19
  20 (define-module (scm output-svg))
  21 (define this-module (current-module))
  22
  23 (use-modules
  24  (guile)
  25  (ice-9 regex)
  26  (ice-9 format)
  27  (lily)
  28  (srfi srfi-1)
  29  (srfi srfi-13))
  30
  31 (define fancy-format format)
  32 (define format ergonomic-simple-format)
  33
  34 (define lily-unit-length 1.75)
  35
  36 (define (dispatch expr)
  37   (let ((keyword (car expr)))
  38     (cond
  39      ((eq? keyword 'some-func) "")
  40      ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
  41      (else
  42       (if (module-defined? this-module keyword)
  43           (apply (eval keyword this-module) (cdr expr))
  44           (begin
  45             (ly:warning (_ "undefined: ~S") keyword)
  46             ""))))))
  47
  48 ;; Helper functions
  49 (define-public (attributes attributes-alist)
  50   (apply string-append
  51          (map (lambda (x) (format " ~s=\"~a\"" (car x) (cdr x)))
  52               attributes-alist)))
  53
  54 (define-public (eo entity . attributes-alist)
  55   "o = open"
  56   (format "<~S~a>\n" entity (attributes attributes-alist)))
  57
  58 (define-public (eoc entity . attributes-alist)
  59   " oc = open/close"
  60   (format "<~S~a/>\n" entity (attributes attributes-alist)))
  61
  62 (define-public (ec entity)
  63   "c = close"
  64   (format "</~S>\n" entity))
  65
  66 (define-public (comment s)
  67   (string-append "<!-- " s " -->\n"))
  68
  69 (define-public (entity entity string . attributes-alist)
  70   (if (equal? string "")
  71       (apply eoc entity attributes-alist)
  72       (string-append
  73        (apply eo (cons entity attributes-alist)) string (ec entity))))
  74
  75 (define (offset->point o)
  76   (format " ~S,~S" (car o)  (- (cdr o))))
  77
  78 (define (number-list->point lst)
  79   (define (helper lst)
  80     (if (null? lst)
  81         '()
  82         (cons (format "~S,~S" (car lst) (cadr lst))
  83               (helper (cddr lst)))))
  84
  85   (string-join (helper lst) " "))
  86
  87
  88 (define (svg-bezier lst close)
  89   (let* ((c0 (car (list-tail lst 3)))
  90          (c123 (list-head lst 3)))
  91     (string-append
  92      (if (not close) "M " "L ")
  93      (offset->point c0)
  94      "C " (apply string-append (map offset->point c123))
  95      (if (not close) "" (string-append
  96                          "L " (offset->point close))))))
  97
  98 (define (sqr x)
  99   (* x x))
 100
 101 (define (integer->entity integer)
 102   (fancy-format "&#x~x;" integer))
 103
 104 (define (char->entity char)
 105   (integer->entity (char->integer char)))
 106
 107 (define (string->entities string)
 108   (apply string-append
 109          (map (lambda (x) (char->entity x)) (string->list string))))
 110
 111 (define svg-element-regexp
 112   (make-regexp "^(<[a-z]+) (.*>)"))
 113
 114 (define pango-description-regexp-comma
 115   (make-regexp ",( Bold)?( Italic)?( Small-Caps)? ([0-9.]+)$"))
 116
 117 (define pango-description-regexp-nocomma
 118   (make-regexp "( Bold)?( Italic)?( Small-Caps)? ([0-9.]+)$"))
 119
 120 (define (pango-description-to-svg-font str expr)
 121   (define alist '())
 122   (define (set-attribute attr val)
 123     (set! alist (assoc-set! alist attr val)))
 124   (let*
 125     ((match-1 (regexp-exec pango-description-regexp-comma str))
 126      (match-2 (regexp-exec pango-description-regexp-nocomma str))
 127      (match (if match-1
 128                 match-1
 129                 match-2)))
 130
 131     (if (regexp-match? match)
 132         (begin
 133           (set-attribute 'font-family (match:prefix match))
 134           (if (string? (match:substring match 1))
 135               (set-attribute 'font-weight "bold"))
 136           (if (string? (match:substring match 2))
 137               (set-attribute 'font-style "italic"))
 138           (if (string? (match:substring match 3))
 139               (set-attribute 'font-variant "small-caps"))
 140           (set-attribute 'font-size
 141                          (/ (string->number (match:substring match 4))
 142                             lily-unit-length))
 143           (set-attribute 'text-anchor "start")
 144           (set-attribute 'fill "currentColor"))
 145         (ly:warning (_ "cannot decypher Pango description: ~a") str))
 146
 147     (apply entity 'text expr (reverse! alist))))
 148
 149 (define (font-smob-to-svg-font font expr)
 150   (let ((name-style (font-name-style font))
 151         (size (modified-font-metric-font-scaling font)))
 152
 153     (entity 'text expr
 154             ;; FIXME: The cdr of `name-style' cannot select the
 155             ;; correct SVG font, so we ignore this information for now
 156             `(font-family . ,(car name-style))
 157             `(font-size . ,size)
 158             '(text-anchor . "start"))))
 159
 160 (define (fontify font expr)
 161   (if (string? font)
 162       (pango-description-to-svg-font font expr)
 163       (font-smob-to-svg-font font expr)))
 164
 165 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 166 ;;; stencil outputters
 167 ;;;
 168
 169 (define (bezier-sandwich lst thick)
 170   (let* ((first (list-tail lst 4))
 171          (first-c0 (car (list-tail first 3)))
 172          (second (list-head lst 4)))
 173     (entity 'path ""
 174             '(stroke-linejoin . "round")
 175             '(stroke-linecap . "round")
 176             '(stroke . "currentColor")
 177             '(fill . "currentColor")
 178             `(stroke-width . ,thick)
 179             `(d . ,(string-append (svg-bezier first #f)
 180                                   (svg-bezier second first-c0)))
 181             )))
 182
 183 (define (char font i)
 184   (dispatch
 185    `(fontify ,font ,(entity 'tspan (char->entity (integer->char i))))))
 186
 187 (define (circle radius thick is-filled)
 188   (entity
 189    'circle ""
 190    '(stroke-linejoin . "round")
 191    '(stroke-linecap . "round")
 192    `(fill . ,(if is-filled "currentColor" "none"))
 193    `(stroke . "currentColor")
 194    `(stroke-width . ,thick)
 195    `(r . ,radius)))
 196
 197 (define (dashed-line thick on off dx dy phase)
 198   (draw-line thick 0 0 dx dy `(style . ,(format "stroke-dasharray:~a,~a;" on off))))
 199
 200 (define (draw-line thick x1 y1 x2 y2 . alist)
 201   (apply entity 'line ""
 202          (append
 203           `((stroke-linejoin . "round")
 204             (stroke-linecap . "round")
 205             (stroke-width . ,thick)
 206             (stroke . "currentColor")
 207             (x1 . ,x1)
 208             (y1 . ,(- y1))
 209             (x2 . ,x2)
 210             (y2 . ,(- y2)))
 211           alist)))
 212
 213 (define (ellipse x-radius y-radius thick is-filled)
 214   (entity
 215    'ellipse ""
 216    '(stroke-linejoin . "round")
 217    '(stroke-linecap . "round")
 218    `(fill . ,(if is-filled "currentColor" "none"))
 219    `(stroke . "currentColor")
 220    `(stroke-width . ,thick)
 221    `(rx . ,x-radius)
 222    `(ry . ,y-radius)))
 223
 224 (define (embedded-svg string)
 225   string)
 226
 227 (define (grob-cause offset grob)
 228   "")
 229
 230 (define (named-glyph font name)
 231   (dispatch
 232    `(fontify ,font ,(entity 'tspan
 233                             (integer->entity
 234                              (ly:font-glyph-name-to-charcode font name))))))
 235
 236 (define (no-origin)
 237   "")
 238
 239 (define (oval x-radius y-radius thick is-filled)
 240   (let ((x-max x-radius)
 241         (x-min (- x-radius))
 242         (y-max y-radius)
 243         (y-min (- y-radius)))
 244     (entity
 245      'path ""
 246      '(stroke-linejoin . "round")
 247      '(stroke-linecap . "round")
 248      `(fill . ,(if is-filled "currentColor" "none"))
 249      `(stroke . "currentColor")
 250      `(stroke-width . ,thick)
 251      `(d . ,(ly:format "M~4f,~4f C~4f,~4f  ~4f,~4f ~4f,~4f S~4f,~4f ~4f,~4f"
 252                x-max 0
 253                x-max y-max
 254                x-min y-max
 255                x-min 0
 256                x-max y-min
 257                x-max 0)))))
 258
 259 (define (path thick commands)
 260   (define (convert-path-exps exps)
 261     (if (pair? exps)
 262         (let*
 263             ((head (car exps))
 264              (rest (cdr exps))
 265              (arity
 266               (cond
 267                ((memq head '(rmoveto rlineto lineto moveto)) 2)
 268                ((memq head '(rcurveto curveto)) 6)
 269                (else 1)))
 270              (args (take rest arity))
 271              (svg-head (assoc-get head '((rmoveto . m)
 272                                          (rcurveto . c)
 273                                          (curveto . C)
 274                                          (moveto . M)
 275                                          (lineto . L)
 276                                          (rlineto . l))
 277                                   ""))
 278              )
 279
 280           (cons (format "~a~a "
 281                         svg-head (number-list->point args)
 282                         )
 283                 (convert-path-exps (drop rest arity))))
 284         '()))
 285
 286   (entity 'path ""
 287           `(stroke-width . ,thick)
 288           '(stroke-linejoin . "round")
 289           '(stroke-linecap . "round")
 290           '(stroke . "currentColor")
 291           '(fill . "none")
 292           `(d . ,(string-join (convert-path-exps commands) " "))))
 293
 294 (define (placebox x y expr)
 295   (if (not (string-null? expr))
 296       (let*
 297         ((match (regexp-exec svg-element-regexp expr))
 298          (tagname (match:substring match 1))
 299          (attributes (match:substring match 2)))
 300
 301         (string-append tagname
 302                        ;; FIXME: Not using GNU coding standards
 303                        ;; [translate ()] here to work around a
 304                        ;; bug in Microsoft Internet Explorer 6.0
 305                        (ly:format " transform=\"translate(~f, ~f)\" "
 306                                   x (- y))
 307                        attributes
 308                        "\n"))
 309       ""))
 310
 311 (define (polygon coords blot-diameter is-filled)
 312   (entity
 313    'polygon ""
 314    '(stroke-linejoin . "round")
 315    '(stroke-linecap . "round")
 316    `(stroke-width . ,blot-diameter)
 317    `(fill . ,(if is-filled "currentColor" "none"))
 318    '(stroke . "currentColor")
 319    `(points . ,(string-join
 320                 (map offset->point (ly:list->offsets '() coords))))
 321    ))
 322
 323 (define (resetcolor)
 324   "</g>\n")
 325
 326 (define (resetrotation ang x y)
 327   "</g>\n")
 328
 329 (define (round-filled-box breapth width depth height blot-diameter)
 330   (entity 'rect ""
 331           ;; The stroke will stick out.  To use stroke,
 332           ;; the stroke-width must be subtracted from all other dimensions.
 333           ;;'(stroke-linejoin . "round")
 334           ;;'(stroke-linecap . "round")
 335           ;;`(stroke-width . ,blot)
 336           ;;'(stroke . "red")
 337           ;;'(fill . "orange")
 338
 339           `(x . ,(- breapth))
 340           `(y . ,(- height))
 341           `(width . ,(+ breapth width))
 342           `(height . ,(+ depth height))
 343           `(ry . ,(/ blot-diameter 2))
 344           '(fill . "currentColor")
 345           ))
 346
 347 (define (setcolor r g b)
 348   (format "<g color=\"rgb(~a%,~a%,~a%)\">\n"
 349           (* 100 r) (* 100 g) (* 100 b)
 350           ))
 351
 352 ;; rotate around given point
 353 (define (setrotation ang x y)
 354   (format "<g transform=\"rotate(~a,~a,~a)\">\n"
 355     (number->string (* -1 ang))
 356     (number->string x)
 357     (number->string (* -1 y))))
 358
 359 (define (text font string)
 360   (dispatch `(fontify ,font ,(entity 'tspan (string->entities string)))))
 361
 362 (define (url-link url x y)
 363   (string-append
 364    (eo 'a `(xlink:href . ,url))
 365    (eoc 'rect
 366         `(x . ,(car x))
 367         `(y . ,(car y))
 368         `(width . ,(- (cdr x) (car x)))
 369         `(height . ,(- (cdr y) (car y)))
 370         '(fill . "none")
 371         '(stroke . "none")
 372         '(stroke-width . "0.0"))
 373    (ec 'a)))
 374
 375 (define (utf-8-string pango-font-description string)
 376   (dispatch `(fontify ,pango-font-description ,(entity 'tspan string))))