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 ;;; catch-all for missing stuff
 169 ;;; comment this out to see find out what functions you miss :-)
 170
 171 (if #f
 172     (begin
 173       (define (dummy . foo) "")
 174       (map (lambda (x) (module-define! this-module x dummy))
 175            (append
 176             (ly:all-stencil-expressions)
 177             (ly:all-output-backend-commands)))
 178       ))
 179
 180 (define (url-link url x y)
 181   (string-append
 182    (eo 'a `(xlink:href . ,url))
 183    (eoc 'rect
 184         `(x . ,(car x))
 185         `(y . ,(car y))
 186         `(width . ,(- (cdr x) (car x)))
 187         `(height . ,(- (cdr y) (car y)))
 188         '(fill . "none")
 189         '(stroke . "none")
 190         '(stroke-width . "0.0"))
 191    (ec 'a)))
 192
 193 (define (grob-cause offset grob)
 194   "")
 195
 196 (define (no-origin)
 197   "")
 198
 199
 200
 201 (define (bezier-sandwich lst thick)
 202   (let* ((first (list-tail lst 4))
 203          (first-c0 (car (list-tail first 3)))
 204          (second (list-head lst 4)))
 205     (entity 'path ""
 206             '(stroke-linejoin . "round")
 207             '(stroke-linecap . "round")
 208             '(stroke . "currentColor")
 209             '(fill . "currentColor")
 210             `(stroke-width . ,thick)
 211             `(d . ,(string-append (svg-bezier first #f)
 212                                   (svg-bezier second first-c0)))
 213             )))
 214
 215 (define (path thick commands)
 216   (define (convert-path-exps exps)
 217     (if (pair? exps)
 218         (let*
 219             ((head (car exps))
 220              (rest (cdr exps))
 221              (arity
 222               (cond
 223                ((memq head '(rmoveto rlineto lineto moveto)) 2)
 224                ((memq head '(rcurveto curveto)) 6)
 225                (else 1)))
 226              (args (take rest arity))
 227              (svg-head (assoc-get head '((rmoveto . m)
 228                                          (rcurveto . c)
 229                                          (curveto . C)
 230                                          (moveto . M)
 231                                          (lineto . L)
 232                                          (rlineto . l))
 233                                   ""))
 234              )
 235
 236           (cons (format "~a~a "
 237                         svg-head (number-list->point args)
 238                         )
 239                 (convert-path-exps (drop rest arity))))
 240         '()))
 241
 242   (entity 'path ""
 243           `(stroke-width . ,thick)
 244           '(stroke-linejoin . "round")
 245           '(stroke-linecap . "round")
 246           '(stroke . "currentColor")
 247           '(fill . "none")
 248           `(d . ,(string-join (convert-path-exps commands) " "))))
 249
 250 (define (char font i)
 251   (dispatch
 252    `(fontify ,font ,(entity 'tspan (char->entity (integer->char i))))))
 253
 254 (define-public (comment s)
 255   (string-append "<!-- " s " -->\n"))
 256
 257 (define (draw-line thick x1 y1 x2 y2 . alist)
 258
 259   (apply entity 'line ""
 260          (append
 261           `((stroke-linejoin . "round")
 262             (stroke-linecap . "round")
 263             (stroke-width . ,thick)
 264             (stroke . "currentColor")
 265             (x1 . ,x1)
 266             (y1 . ,(- y1))
 267             (x2 . ,x2)
 268             (y2 . ,(- y2)))
 269           alist)))
 270
 271 (define (dashed-line thick on off dx dy phase)
 272   (draw-line thick 0 0 dx dy `(style . ,(format "stroke-dasharray:~a,~a;" on off))))
 273
 274 (define (named-glyph font name)
 275   (dispatch
 276    `(fontify ,font ,(entity 'tspan
 277                             (integer->entity
 278                              (ly:font-glyph-name-to-charcode font name))))))
 279
 280 (define (placebox x y expr)
 281   (let*
 282     ((match (regexp-exec svg-element-regexp expr))
 283      (tagname (match:substring match 1))
 284      (attributes (match:substring match 2)))
 285
 286     (string-append tagname
 287                    ;; FIXME: Not using GNU coding standards
 288                    ;; [translate ()] here to work around a
 289                    ;; bug in Microsoft Internet Explorer 6.0
 290                    (ly:format " transform=\"translate(~f, ~f)\" " x (- y))
 291                    attributes
 292                    "\n")))
 293
 294 (define (polygon coords blot-diameter is-filled)
 295   (entity
 296    'polygon ""
 297    '(stroke-linejoin . "round")
 298    '(stroke-linecap . "round")
 299    `(stroke-width . ,blot-diameter)
 300    `(fill . ,(if is-filled "currentColor" "none"))
 301    '(stroke . "currentColor")
 302    `(points . ,(string-join
 303                 (map offset->point (ly:list->offsets '() coords))))
 304    ))
 305
 306 ;; rotate around given point
 307 (define (setrotation ang x y)
 308   (format "<g transform=\"rotate(~a,~a,~a)\">\n"
 309     (number->string (* -1 ang))
 310     (number->string x)
 311     (number->string (* -1 y))))
 312
 313 (define (resetrotation ang x y)
 314   "</g>\n")
 315
 316 (define (round-filled-box breapth width depth height blot-diameter)
 317   (entity 'rect ""
 318           ;; The stroke will stick out.  To use stroke,
 319           ;; the stroke-width must be subtracted from all other dimensions.
 320           ;;'(stroke-linejoin . "round")
 321           ;;'(stroke-linecap . "round")
 322           ;;`(stroke-width . ,blot)
 323           ;;'(stroke . "red")
 324           ;;'(fill . "orange")
 325
 326           `(x . ,(- breapth))
 327           `(y . ,(- height))
 328           `(width . ,(+ breapth width))
 329           `(height . ,(+ depth height))
 330           `(ry . ,(/ blot-diameter 2))
 331           '(fill . "currentColor")
 332           ))
 333
 334 (define (circle radius thick is-filled)
 335   (entity
 336    'circle ""
 337    '(stroke-linejoin . "round")
 338    '(stroke-linecap . "round")
 339    `(fill . ,(if is-filled "currentColor" "none"))
 340    `(stroke . "currentColor")
 341    `(stroke-width . ,thick)
 342    `(r . ,radius)))
 343
 344 (define (ellipse x-radius y-radius thick is-filled)
 345   (entity
 346    'ellipse ""
 347    '(stroke-linejoin . "round")
 348    '(stroke-linecap . "round")
 349    `(fill . ,(if is-filled "currentColor" "none"))
 350    `(stroke . "currentColor")
 351    `(stroke-width . ,thick)
 352    `(rx . ,x-radius)
 353    `(ry . ,y-radius)))
 354
 355 (define (oval x-radius y-radius thick is-filled)
 356   (let ((x-max x-radius)
 357         (x-min (- x-radius))
 358         (y-max y-radius)
 359         (y-min (- y-radius)))
 360     (entity
 361      'path ""
 362      '(stroke-linejoin . "round")
 363      '(stroke-linecap . "round")
 364      `(fill . ,(if is-filled "currentColor" "none"))
 365      `(stroke . "currentColor")
 366      `(stroke-width . ,thick)
 367      `(d . ,(ly:format "M~4f,~4f C~4f,~4f  ~4f,~4f ~4f,~4f S~4f,~4f ~4f,~4f"
 368                x-max 0
 369                x-max y-max
 370                x-min y-max
 371                x-min 0
 372                x-max y-min
 373                x-max 0)))))
 374
 375 (define (text font string)
 376   (dispatch `(fontify ,font ,(entity 'tspan (string->entities string)))))
 377
 378 (define (utf-8-string pango-font-description string)
 379   (dispatch `(fontify ,pango-font-description ,(entity 'tspan string))))
 380
 381 (define (embedded-svg string)
 382   string)
 383
 384 (define (setcolor r g b)
 385   (format "<g color=\"rgb(~a%,~a%,~a%)\">\n"
 386           (* 100 r) (* 100 g) (* 100 b)
 387           ))
 388
 389 (define (resetcolor)
 390   "</g>\n")