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