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