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