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--2004 Jan Nieuwenhuizen <janneke@gnu.org>
   6
   7 ;;;; http://www.w3.org/TR/SVG11/paths.html
   8
   9
  10 ;;; TODO: character selects by index from [custom] fonts
  11
  12 (debug-enable 'backtrace)
  13 (define-module (scm output-svg))
  14 (define this-module (current-module))
  15
  16 (use-modules
  17  (guile)
  18  (ice-9 regex)
  19  (lily))
  20
  21 ;; GLobals
  22 ;; FIXME: 2?
  23 (define output-scale (* 2 scale-to-unit))
  24 (define line-thickness 0)
  25
  26 (define (stderr string . rest)
  27   (apply format (cons (current-error-port) (cons string rest)))
  28   (force-output (current-error-port)))
  29
  30 (define (debugf string . rest)
  31   (if #f
  32       (apply stderr (cons string rest))))
  33
  34
  35 (define (dispatch expr)
  36   (let ((keyword (car expr)))
  37     (cond
  38      ((eq? keyword 'some-func) "")
  39      ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
  40      (else
  41       (if (module-defined? this-module keyword)
  42           (apply (eval keyword this-module) (cdr expr))
  43           (begin
  44             (display
  45              (string-append "undefined: " (symbol->string keyword) "\n"))
  46             ""))))))
  47
  48 ;; Helper functions
  49 (define (tagify tag string . attribute-alist)
  50   (string-append
  51    "<"
  52    tag
  53    (apply string-append
  54           (map (lambda (x)
  55                  (string-append " " (symbol->string (car x)) "='" (cdr x) "'"))
  56                attribute-alist))
  57    ">"
  58    string "</" tag ">\n"))
  59
  60 (define (control->list c)
  61   (list (car c) (cdr c)))
  62
  63 (define (control->string c)
  64   (string-append
  65    (number->string (car c)) ","
  66    ;; lose the -1
  67    (number->string (* -1 (cdr c))) " "))
  68
  69 (define (control-flip-y c)
  70   (cons (car c) (* -1 (cdr c))))
  71
  72 (define (ly:numbers->string l)
  73   (string-append
  74    (number->string (car l))
  75    (if (null? (cdr l))
  76        ""
  77        (string-append "," (ly:numbers->string (cdr l))))))
  78
  79 (define (svg-bezier l close)
  80   (let* ((c0 (car (list-tail l 3)))
  81          (c123 (list-head l 3)))
  82     (string-append
  83      (if (not close) "M " "L ")
  84      (control->string c0)
  85      "C " (apply string-append (map control->string c123))
  86      (if (not close) "" (string-append
  87                          "L " (control->string close))))));; " Z")))))
  88
  89
  90 (define (sqr x)
  91   (* x x))
  92
  93 (define (fontify font expr)
  94    (tagify "text" expr (cons 'style (svg-font font))))
  95 ;;         (cons 'unicode-range "U+EE00-EEFF"))))
  96
  97 ;;;;;;;;;;;;;;;;;;; share this utf8 stuff from output-gnome
  98 ;;;;;;;;;;;;;;;;;;;
  99 (define (utf8 i)
 100   (cond
 101    ((< i #x80) (list (integer->char i)))
 102    ((< i #x800) (map integer->char
 103                      (list (+ #xc0 (quotient i #x40))
 104                            (+ #x80 (modulo i #x40)))))
 105    ((< i #x10000)
 106     (let ((x (quotient i #x1000))
 107           (y (modulo i #x1000)))
 108       (map integer->char
 109            (list (+ #xe0 x)
 110                  (+ #x80 (quotient y #x40))
 111                  (+ #x80 (modulo y #x40))))))
 112    (else FIXME)))
 113
 114 (define (custom-utf8 i)
 115   (if (< i 80)
 116       (utf8 i)
 117       (utf8 (+ #xee00 i))))
 118
 119 (define (string->utf8-string string)
 120   (list->string
 121    (apply append (map utf8 (map char->integer (string->list string))))))
 122
 123 (define (char->utf8-string char)
 124   (list->string (utf8 (char->integer char))))
 125 ;;  (list->string (custom-utf8 (char->integer char))))
 126 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 127
 128
 129 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 130 ;;; stencil outputters
 131 ;;;
 132
 133 ;;; catch-all for missing stuff
 134 ;;; comment this out to see find out what functions you miss :-)
 135 (define (dummy . foo) "")
 136 (map (lambda (x) (module-define! this-module x dummy))
 137      (append
 138       (ly:all-stencil-expressions)
 139       (ly:all-output-backend-commands)))
 140
 141 (define (beam width slope thick blot)
 142   (let* ((x width)
 143          (y (* slope width))
 144          (z (sqrt (+ (sqr x) (sqr y)))))
 145     (tagify "rect" ""
 146             `(style . ,(format "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-opacity:1;stroke-width:~f;stroke-linejoin:round;stroke-linecap:round;" line-thickness))
 147             `(x . "0")
 148             `(y . ,(number->string (* output-scale (- 0 (/ thick 2)))))
 149             `(width . ,(number->string (* output-scale width)))
 150             `(height . ,(number->string (* output-scale thick)))
 151             ;;`(ry . ,(number->string (* output-scale half-lt)))
 152             `(ry . ,(number->string (* output-scale (/ line-thickness 2))))
 153             `(transform .
 154                         ,(format #f "matrix (~f, ~f, 0, 1, 0, 0) scale (~f, ~f)"
 155                                  (/ x z)
 156                                  (* -1 (/ y z))
 157                                  1 1)))))
 158
 159 (define (bezier-sandwich l thick)
 160   (let* (;;(l (eval urg-l this-module))
 161          (first (list-tail l 4))
 162          (first-c0 (car (list-tail first 3)))
 163          (second (list-head l 4)))
 164     (tagify "path" ""
 165             `(stroke . "#000000")
 166             `(stroke-width . ,(number->string line-thickness))
 167             `(transform . ,(format #f "scale (~f, ~f)"
 168                                    output-scale output-scale))
 169             `(d . ,(string-append (svg-bezier first #f)
 170                                   (svg-bezier second first-c0))))))
 171
 172 (define (char font i)
 173   (dispatch
 174    `(fontify ,font ,(tagify "tspan" (char->utf8-string
 175                                      (integer->char i))))))
 176
 177 (define (comment s)
 178   (string-append "<!-- " s " !-->\n"))
 179
 180 (define (filledbox breapth width depth height)
 181   (round-filled-box breapth width depth height line-thickness))
 182
 183 (define (lily-def key val)
 184   (cond
 185    ((equal? key "lilypondpaperoutputscale")
 186     ;; ugr
 187     ;; If we just use transform scale (output-scale),
 188     ;; all fonts come out scaled too (ie, much too big)
 189     ;; So, we manually scale all other stuff.
 190     (set! output-scale (* scale-to-unit (string->number val))))
 191    ((equal? key "lilypondpaperlinethickness")
 192     (set! line-thickness (* scale-to-unit (string->number val)))))
 193   "")
 194
 195 (define (placebox x y expr)
 196   (tagify "g"
 197           ;; FIXME -- JCN
 198           ;;(dispatch expr)
 199           expr
 200           `(transform . ,(format #f "translate (~f, ~f)"
 201                                  (* output-scale x)
 202                                  (- 0 (* output-scale y))))))
 203
 204 (define (round-filled-box breapth width depth height blot-diameter)
 205   (tagify "rect" ""
 206             `(style . ,(format "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-opacity:1;stroke-width:~f;stroke-linejoin:miter;stroke-linecap:butt;" line-thickness))
 207           `(x . ,(number->string (* output-scale (- 0 breapth))))
 208           `(y . ,(number->string (* output-scale (- 0 height))))
 209           `(width . ,(number->string (* output-scale (+ breapth width))))
 210           `(height . ,(number->string (* output-scale (+ depth height))))
 211           ;;`(ry . ,(number->string (* output-scale half-lt)))
 212           `(ry . ,(number->string (/ blot-diameter 2)))))
 213
 214 (define (svg-font font)
 215    (define (font-family)
 216      (let ((name (ly:font-name font)))
 217        (if name
 218            (regexp-substitute/global #f "^GNU-(.*)-[.0-9]*$" name 'pre 1 'post)
 219            (begin
 220              (stderr "font-name: ~S\n" (ly:font-name font))
 221              ;; TODO s/filename/file-name/
 222              (stderr "font-filename: ~S\n" (ly:font-filename font))
 223              (stderr "font-size: ~S\n" (font-size))
 224              "ecrm12"))))
 225
 226    (define (font-size)
 227     (let* ((designsize (ly:font-design-size font))
 228            (magnification (* (ly:font-magnification font)))
 229            (scaling (* magnification designsize)))
 230       (debugf "scaling:~S\n" scaling)
 231       (debugf "magnification:~S\n" magnification)
 232       (debugf "design:~S\n" designsize)
 233       scaling))
 234
 235    (format #f "font-family:~a;font-size:~a;fill:black;text-anchor:start;"
 236            (font-family) (font-size)))
 237
 238 (define (text font string)
 239   (dispatch `(fontify ,font ,(tagify "tspan" (string->utf8-string string)))))
 240
 241 ;; WTF is this in every backend?
 242 (define (horizontal-line x1 x2 th)
 243   (filledbox (- x1) (- x2 x1) (* .5 th) (* .5 th)))