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 (define format ergonomic-simple-format)
  31
  32 (define lily-unit-length 1.75)
  33
  34 (define (dispatch expr)
  35   (let ((keyword (car expr)))
  36     (cond
  37      ((eq? keyword 'some-func) "")
  38      ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
  39      (else
  40       (if (module-defined? this-module keyword)
  41           (apply (eval keyword this-module) (cdr expr))
  42           (begin
  43             (ly:warning (_ "undefined: ~S") keyword)
  44             ""))))))
  45
  46 ;; Helper functions
  47 (define-public (attributes attributes-alist)
  48   (apply string-append
  49          (map (lambda (x) (format " ~s=\"~a\"" (car x) (cdr x)))
  50               attributes-alist)))
  51
  52 (define-public (eo entity . attributes-alist)
  53   "o = open"
  54   (format "<~S~a>\n" entity (attributes attributes-alist)))
  55
  56 (define-public (eoc entity . attributes-alist)
  57   " oc = open/close"
  58   (format "<~S~a/>\n" entity (attributes attributes-alist)))
  59
  60 (define-public (ec entity)
  61   "c = close"
  62   (format "</~S>\n" entity))
  63
  64
  65
  66 (define-public (entity entity string . attributes-alist)
  67   (if (equal? string "")
  68       (apply eoc entity attributes-alist)
  69       (string-append
  70        (apply eo (cons entity attributes-alist)) string (ec entity))))
  71
  72 (define (offset->point o)
  73   (format " ~S,~S" (car o)  (- (cdr o))))
  74
  75 (define (number-list->point lst)
  76   (define (helper lst)
  77     (if (null? lst)
  78         '()
  79         (cons (format "~S,~S" (car lst) (cadr lst))
  80               (helper (cddr lst)))))
  81
  82   (string-join (helper lst) " "))
  83
  84
  85 (define (svg-bezier lst close)
  86   (let* ((c0 (car (list-tail lst 3)))
  87          (c123 (list-head lst 3)))
  88     (string-append
  89      (if (not close) "M " "L ")
  90      (offset->point c0)
  91      "C " (apply string-append (map offset->point c123))
  92      (if (not close) "" (string-append
  93                          "L " (offset->point close))))))
  94
  95 (define (sqr x)
  96   (* x x))
  97
  98 (define (integer->entity integer)
  99   (format "&#x~x;" integer))
 100
 101 (define (char->entity char)
 102   (integer->entity (char->integer char)))
 103
 104 (define (string->entities string)
 105   (apply string-append
 106          (map (lambda (x) (char->entity x)) (string->list string))))
 107
 108 (define pango-description-regexp-comma
 109   (make-regexp "([^,]+), ?([-a-zA-Z_]*) ([0-9.]+)$"))
 110
 111 (define pango-description-regexp-nocomma
 112   (make-regexp "([^ ]+) ([-a-zA-Z_]*) ?([0-9.]+)$"))
 113
 114 (define (pango-description-to-svg-font str)
 115   (let*
 116       ((size 4.0)
 117        (family "Helvetica")
 118        (style #f)
 119        (match-1 (regexp-exec pango-description-regexp-comma str))
 120        (match-2 (regexp-exec pango-description-regexp-nocomma str))
 121        (match (if match-1
 122                   match-1
 123                   match-2)))
 124
 125     (if (regexp-match? match)
 126         (begin
 127           (set! family (match:substring match 1))
 128           (if (< 0 (string-length (match:substring match 2)))
 129               (set! style (match:substring match 2)))
 130           (set! size
 131                 (string->number (match:substring match 3))))
 132
 133         (ly:warning (_ "cannot decypher Pango description: ~a") str))
 134
 135     (set! style
 136           (if (string? style)
 137               (format "font-style:~a;" style)
 138               ""))
 139
 140     (format "font-family:~a;~afont-size:~a;text-anchor:west"
 141             family
 142             style
 143             (/ size lily-unit-length))
 144     ))
 145
 146 ;;; FONT may be font smob, or pango font string
 147 (define (svg-font font)
 148   (if (string? font)
 149       (pango-description-to-svg-font font)
 150       (let ((name-style (font-name-style font))
 151             (size (modified-font-metric-font-scaling font))
 152             (anchor "west"))
 153
 154         (format "font-family:~a;font-style:~a;font-size:~a;text-anchor:~a;"
 155                 (car name-style) (cadr name-style)
 156                 size anchor))))
 157
 158 (define (fontify font expr)
 159   (entity 'text expr
 160           `(style . ,(svg-font font))
 161           '(fill . "currentColor")
 162           ))
 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   (entity 'g
 282           expr
 283           ;; FIXME: Not using GNU coding standards [translate ()] here
 284           ;; to work around a bug in Microsoft Internet Explorer 6.0
 285           `(transform . ,(format "translate(~f, ~f)"
 286                                  x (- y)))))
 287
 288 (define (polygon coords blot-diameter is-filled)
 289   (entity
 290    'polygon ""
 291    '(stroke-linejoin . "round")
 292    '(stroke-linecap . "round")
 293    `(stroke-width . ,blot-diameter)
 294    `(fill . ,(if is-filled "currentColor" "none"))
 295    '(stroke . "currentColor")
 296    `(points . ,(string-join
 297                 (map offset->point (ly:list->offsets '() coords))))
 298    ))
 299
 300 ;; rotate around given point
 301 (define (setrotation ang x y)
 302   (format "<g transform=\"rotate(~a,~a,~a)\">"
 303     (number->string (* -1 ang))
 304     (number->string x)
 305     (number->string (* -1 y))))
 306
 307 (define (resetrotation ang x y)
 308   "</g>")
 309
 310 (define (round-filled-box breapth width depth height blot-diameter)
 311   (entity 'rect ""
 312           ;; The stroke will stick out.  To use stroke,
 313           ;; the stroke-width must be subtracted from all other dimensions.
 314           ;;'(stroke-linejoin . "round")
 315           ;;'(stroke-linecap . "round")
 316           ;;`(stroke-width . ,blot)
 317           ;;'(stroke . "red")
 318           ;;'(fill . "orange")
 319
 320           `(x . ,(- breapth))
 321           `(y . ,(- height))
 322           `(width . ,(+ breapth width))
 323           `(height . ,(+ depth height))
 324           `(ry . ,(/ blot-diameter 2))
 325           ))
 326
 327 (define (circle radius thick is-filled)
 328   (entity
 329    'circle ""
 330    '(stroke-linejoin . "round")
 331    '(stroke-linecap . "round")
 332    `(fill . ,(if is-filled "currentColor" "none"))
 333    `(stroke . "currentColor")
 334    `(stroke-width . ,thick)
 335    `(r . ,radius)))
 336
 337 (define (text font string)
 338   (dispatch `(fontify ,font ,(entity 'tspan (string->entities string)))))
 339
 340 (define (utf-8-string pango-font-description string)
 341   (dispatch `(fontify ,pango-font-description ,(entity 'tspan string))))
 342
 343
 344
 345 (define (setcolor r g b)
 346   (format "<g color=\"rgb(~a%,~a%,~a%)\">"
 347           (* 100 r) (* 100 g) (* 100 b)
 348           ))
 349
 350 (define (resetcolor)
 351   "</g>")