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--2006 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  (lily)
  27  (srfi srfi-1)
  28  (srfi srfi-13))
  29
  30
  31 (define lily-unit-length 1.75)
  32
  33 (define (dispatch expr)
  34   (let ((keyword (car expr)))
  35     (cond
  36      ((eq? keyword 'some-func) "")
  37      ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
  38      (else
  39       (if (module-defined? this-module keyword)
  40           (apply (eval keyword this-module) (cdr expr))
  41           (begin
  42             (ly:warning (_ "undefined: ~S") keyword)
  43             ""))))))
  44
  45 ;; Helper functions
  46 (define-public (attributes attributes-alist)
  47   (apply string-append
  48          (map (lambda (x) (format #f " ~s=\"~a\"" (car x) (cdr x)))
  49               attributes-alist)))
  50
  51 (define-public (eo entity . attributes-alist)
  52   "o = open"
  53   (format #f "<~S~a>\n" entity (attributes attributes-alist)))
  54
  55 (define-public (eoc entity . attributes-alist)
  56   " oc = open/close"
  57   (format #f "<~S~a/>\n" entity (attributes attributes-alist)))
  58
  59 (define-public (ec entity)
  60   "c = close"
  61   (format #f "</~S>\n" entity))
  62
  63
  64
  65 (define-public (entity entity string . attributes-alist)
  66   (if (equal? string "")
  67       (apply eoc entity attributes-alist)
  68       (string-append
  69        (apply eo (cons entity attributes-alist)) string (ec entity))))
  70
  71 (define (offset->point o)
  72   (format #f " ~S,~S" (car o)  (- (cdr o))))
  73
  74 (define (number-list->point lst)
  75   (define (helper lst)
  76     (if (null? lst)
  77         '()
  78         (cons (format "~S,~S" (car lst) (cadr lst))
  79               (helper (cddr lst)))))
  80
  81   (string-join (helper lst) " "))
  82
  83
  84 (define (svg-bezier lst close)
  85   (let* ((c0 (car (list-tail lst 3)))
  86          (c123 (list-head lst 3)))
  87     (string-append
  88      (if (not close) "M " "L ")
  89      (offset->point c0)
  90      "C " (apply string-append (map offset->point c123))
  91      (if (not close) "" (string-append
  92                          "L " (offset->point close))))))
  93
  94 (define (sqr x)
  95   (* x x))
  96
  97 (define (integer->entity integer)
  98   (format #f "&#x~x;" integer))
  99
 100 (define (char->entity char)
 101   (integer->entity (char->integer char)))
 102
 103 (define (string->entities string)
 104   (apply string-append
 105          (map (lambda (x) (char->entity x)) (string->list string))))
 106
 107 (define pango-description-regexp-comma
 108   (make-regexp "^([^,]+), ?([-a-zA-Z_]*) ([0-9.]+)$"))
 109
 110 (define pango-description-regexp-nocomma
 111   (make-regexp "^([^ ]+) ([-a-zA-Z_]*) ?([0-9.]+)$"))
 112
 113 (define (pango-description-to-svg-font str)
 114   (let*
 115       ((size 4.0)
 116        (family "Helvetica")
 117        (style #f)
 118        (match-1 (regexp-exec pango-description-regexp-comma str))
 119        (match-2 (regexp-exec pango-description-regexp-nocomma str))
 120        (match (if match-1
 121                   match-1
 122                   match-2)))
 123
 124     (if (regexp-match? match)
 125         (begin
 126           (set! family (match:substring match 1))
 127           (if (< 0 (string-length (match:substring match 2)))
 128               (set! style (match:substring match 2)))
 129           (set! size
 130                 (string->number (match:substring match 3))))
 131
 132         (ly:warning (_ "can't decypher Pango description: ~a") str))
 133
 134     (set! style
 135           (if (string? style)
 136               (format "font-style:~a;" style)
 137               ""))
 138
 139     (format "font-family:~a;~afont-size:~a;text-anchor:west"
 140             family
 141             style
 142             (/ size lily-unit-length))
 143     ))
 144
 145 ;;; FONT may be font smob, or pango font string
 146 (define (svg-font font)
 147   (if (string? font)
 148       (pango-description-to-svg-font font)
 149       (let ((name-style (font-name-style font))
 150             (size (modified-font-metric-font-scaling font))
 151             (anchor "west"))
 152
 153         (format #f "font-family:~a;font-style:~a;font-size:~a;text-anchor:~a;"
 154                 (car name-style) (cadr name-style)
 155                 size anchor))))
 156
 157 (define (fontify font expr)
 158   (entity 'text expr
 159           `(style . ,(svg-font font))
 160           '(fill . "currentColor")
 161           ))
 162
 163 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 164 ;;; stencil outputters
 165 ;;;
 166
 167 ;;; catch-all for missing stuff
 168 ;;; comment this out to see find out what functions you miss :-)
 169
 170 (if #f
 171     (begin
 172       (define (dummy . foo) "")
 173       (map (lambda (x) (module-define! this-module x dummy))
 174            (append
 175             (ly:all-stencil-expressions)
 176             (ly:all-output-backend-commands)))
 177       ))
 178
 179 (define (url-link url x y)
 180   (string-append
 181    (eo 'a `(xlink:href . ,url))
 182    (eoc 'rect
 183         `(x . ,(car x))
 184         `(y . ,(car y))
 185         `(width . ,(- (cdr x) (car x)))
 186         `(height . ,(- (cdr y) (car y)))
 187         '(fill . "none")
 188         '(stroke . "none")
 189         '(stroke-width . "0.0"))
 190    (ec 'a)))
 191
 192 (define (grob-cause offset grob)
 193   "")
 194
 195 (define (no-origin)
 196   "")
 197
 198
 199
 200 (define (bezier-sandwich lst thick)
 201   (let* ((first (list-tail lst 4))
 202          (first-c0 (car (list-tail first 3)))
 203          (second (list-head lst 4)))
 204     (entity 'path ""
 205             '(stroke-linejoin . "round")
 206             '(stroke-linecap . "round")
 207             '(stroke . "currentColor")
 208             '(fill . "currentColor")
 209             `(stroke-width . ,thick)
 210             `(d . ,(string-append (svg-bezier first #f)
 211                                   (svg-bezier second first-c0)))
 212             )))
 213
 214 (define (path thick commands)
 215   (define (convert-path-exps exps)
 216     (if (pair? exps)
 217         (let*
 218             ((head (car exps))
 219              (rest (cdr exps))
 220              (arity
 221               (cond
 222                ((memq head '(rmoveto rlineto lineto moveto)) 2)
 223                ((memq head '(rcurveto curveto)) 6)
 224                (else 1)))
 225              (args (take rest arity))
 226              (svg-head (assoc-get head '((rmoveto . m)
 227                                          (rcurveto . c)
 228                                          (curveto . C)
 229                                          (moveto . M)
 230                                          (lineto . L)
 231                                          (rlineto . l))
 232                                   ""))
 233              )
 234
 235           (cons (format "~a~a "
 236                         svg-head (number-list->point args)
 237                         )
 238                 (convert-path-exps (drop rest arity))))
 239         '()))
 240
 241   (entity 'path ""
 242           `(stroke-width . ,thick)
 243           '(stroke-linejoin . "round")
 244           '(stroke-linecap . "round")
 245           '(stroke . "currentColor")
 246           '(fill . "none")
 247           `(d . ,(string-join (convert-path-exps commands) " "))))
 248
 249 (define (char font i)
 250   (dispatch
 251    `(fontify ,font ,(entity 'tspan (char->entity (integer->char i))))))
 252
 253 (define-public (comment s)
 254   (string-append "<!-- " s " !-->\n"))
 255
 256 (define (draw-line thick x1 y1 x2 y2 . alist)
 257
 258   (apply entity 'line ""
 259          (append
 260           `((stroke-linejoin . "round")
 261             (stroke-linecap . "round")
 262             (stroke-width . ,thick)
 263             (stroke . "currentColor")
 264             (x1 . ,x1)
 265             (y1 . ,(- y1))
 266             (x2 . ,x2)
 267             (y2 . ,(- y2)))
 268           alist)))
 269
 270 (define (dashed-line thick on off dx dy phase)
 271   (draw-line thick 0 0 dx dy `(style . ,(format "stroke-dasharray:~a,~a;" on off))))
 272
 273 (define (named-glyph font name)
 274   (dispatch
 275    `(fontify ,font ,(entity 'tspan
 276                             (integer->entity
 277                              (ly:font-glyph-name-to-charcode font name))))))
 278
 279 (define (placebox x y expr)
 280   (entity 'g
 281           expr
 282           ;; FIXME: Not using GNU coding standards [translate ()] here
 283           ;; to work around a bug in Microsoft Internet Explorer 6.0
 284           `(transform . ,(format #f "translate(~f, ~f)"
 285                                  x (- y)))))
 286
 287 (define (polygon coords blot-diameter is-filled)
 288   (entity
 289    'polygon ""
 290    '(stroke-linejoin . "round")
 291    '(stroke-linecap . "round")
 292    `(stroke-width . ,blot-diameter)
 293    `(fill . ,(if is-filled "currentColor" "none"))
 294    '(stroke . "currentColor")
 295    `(points . ,(string-join
 296                 (map offset->point (ly:list->offsets '() coords))))
 297    ))
 298
 299 ;; rotate around given point
 300 (define (setrotation ang x y)
 301   (format "<g transform=\"rotate(~a,~a,~a)\">"
 302     (number->string (* -1 ang))
 303     (number->string x)
 304     (number->string (* -1 y))))
 305
 306 (define (resetrotation ang x y)
 307   "</g>")
 308
 309 (define (round-filled-box breapth width depth height blot-diameter)
 310   (entity 'rect ""
 311           ;; The stroke will stick out.  To use stroke,
 312           ;; the stroke-width must be subtracted from all other dimensions.
 313           ;;'(stroke-linejoin . "round")
 314           ;;'(stroke-linecap . "round")
 315           ;;`(stroke-width . ,blot)
 316           ;;'(stroke . "red")
 317           ;;'(fill . "orange")
 318
 319           `(x . ,(- breapth))
 320           `(y . ,(- height))
 321           `(width . ,(+ breapth width))
 322           `(height . ,(+ depth height))
 323           `(ry . ,(/ blot-diameter 2))
 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 (text font string)
 337   (dispatch `(fontify ,font ,(entity 'tspan (string->entities string)))))
 338
 339 (define (utf-8-string pango-font-description string)
 340   (dispatch `(fontify ,pango-font-description ,(entity 'tspan string))))
 341
 342
 343
 344 (define (setcolor r g b)
 345   (format "<g color=\"rgb(~a%,~a%,~a%)\">"
 346           (* 100 r) (* 100 g) (* 100 b)
 347           ))
 348
 349 (define (resetcolor)
 350   "</g>")