scm/output-sodipodi.scm

   1 ;;;; sodipodi.scm -- implement Scheme output routines for PostScript
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c)  2002--2003 Jan Nieuwenhuizen <janneke@gnu.org>
   6
   7 ;;;; NOTE:
   8 ;;;;
   9 ;;;; * Get mftrace 1.0.12 or newer to create the .pfa fonts:
  10 ;;;;
  11 ;;;;       make -C mf clean
  12 ;;;;       make -C mf pfa
  13 ;;;;
  14 ;;;; * Get sodipodi-0.28 or newer
  15 ;;;;
  16 ;;;; * Link/copy mf/out/private-fonts to ~/.sodipodi/private-fonts
  17
  18 ;;;; http://www.w3.org/TR/SVG11/paths.html
  19
  20
  21 (debug-enable 'backtrace)
  22
  23 (define-module (scm output-sodipodi))
  24 (define this-module (current-module))
  25
  26 (use-modules
  27  (guile)
  28  (lily))
  29
  30 ;;; Lily output interface --- cleanup and docme
  31
  32 ;;; Bare minimum interface for \score { \notes c } }
  33 ;;; should implement:
  34 ;;;
  35 ;;;    xx-output-expression
  36 ;;;    char
  37 ;;;    filledbox
  38 ;;;    placebox
  39
  40 ;;; and should intercept:
  41 ;;;
  42 ;;;    fontify
  43 ;;;    lily-def
  44 ;;;    header-end
  45 ;;;    define-fonts
  46 ;;;    no-origin
  47 ;;;    start-system
  48 ;;;    end-output
  49 ;;;    header
  50 ;;;    comment
  51 ;;;    stop-last-system
  52
  53 ;; Module entry
  54 ;;(define-public (sodipodi-output-expression expr port)
  55 ;;  (display (eval expr this-module) port))
  56
  57 (define-public (sodipodi-output-expression expr port)
  58   (display (dispatch expr) port))
  59
  60 (define (dispatch expr)
  61   (let ((keyword (car expr)))
  62     (cond
  63      ((eq? keyword 'some-func) "")
  64      ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
  65      ;;((eq? keyword 'fontify) (dispatch (caddr expr)))
  66      (else
  67       (if (module-defined? this-module keyword)
  68           (apply (eval keyword this-module) (cdr expr))
  69           (begin
  70             (display
  71              (string-append "undefined: " (symbol->string keyword) "\n"))
  72             ""))))))
  73
  74
  75 ;; Global vars
  76
  77 (define output-scale 1)
  78 (define system-y 0)
  79 ;; huh?
  80 (define urg-line-thickness 0)
  81 (define line-thickness 0.001)
  82 (define half-lt (/ line-thickness 2))
  83
  84
  85 (define scale-to-unit
  86   (cond
  87    ((equal? (ly:unit) "mm") (/ 72.0  25.4))
  88    ((equal? (ly:unit) "pt") (/ 72.0  72.27))
  89    (else (error "unknown unit" (ly:unit)))))
  90
  91 ;; alist containing fontname -> fontcommand assoc (both strings)
  92 ;;(define font-name-alist '())
  93
  94 ;; Helper functions
  95
  96
  97 (define (tagify tag string . attribute-alist)
  98   (string-append
  99    "<" tag
 100    (apply string-append (map (lambda (x) (string-append
 101                                           " "
 102                                           (symbol->string (car x))
 103                                           "='"
 104                                           (cdr x)
 105                                           "'"))
 106                              attribute-alist))
 107    ">\n"
 108    string "\n</" tag ">\n"))
 109
 110
 111 (define (ascii->string i) (make-string 1 (integer->char i)))
 112 (define (ascii->upm-string i)
 113   (let* ((i+1 (+ i 1))
 114          (u1 #xee)
 115          (u2 (+ #x80 (quotient i+1 #x40)))
 116          (u3 (+ #x80 (modulo i+1 #x40))))
 117     (apply string-append
 118            (map ascii->string
 119                 (list u1 u2 u3)))))
 120
 121 (define (control->list c)
 122   (list (car c) (cdr c)))
 123
 124 (define (control->string c)
 125   (string-append
 126    (number->string (car c)) ","
 127    ;; loose the -1
 128    (number->string (* -1 (cdr c))) " "))
 129
 130 (define (control-flip-y c)
 131   (cons (car c) (* -1 (cdr c))))
 132
 133 (define (numbers->string l)
 134   (string-append
 135    (number->string (car l))
 136    (if (null? (cdr l))
 137        ""
 138        (string-append ","  (numbers->string (cdr l))))))
 139
 140 (define (svg-bezier l close)
 141   (let* ((c0 (car (list-tail l 3)))
 142          (c123 (list-head l 3)))
 143     (string-append
 144      (if (not close) "M " "L ")
 145      (control->string c0)
 146      "C " (apply string-append (map control->string c123))
 147      (if (not close) "" (string-append
 148                          "L " (control->string close))))));; " Z")))))
 149
 150 (define xml-header
 151 "<?xml version='1.0' standalone='no'?>
 152 <!DOCTYPE svg PUBLIC '-//W3C//DTD SVG 20010904//EN'
 153 'http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd'
 154 [
 155  <!ATTLIST svg
 156  xmlns:xlink CDATA #FIXED 'http://www.w3.org/1999/xlink'>
 157 ]>
 158 "
 159 ;;"
 160 )
 161
 162 (define svg-header
 163 "<svg
 164    id='svg1'
 165    sodipodi:version='0.26'
 166    xmlns='http://www.w3.org/2000/svg'
 167    xmlns:sodipodi='http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd'
 168    xmlns:xlink='http://www.w3.org/1999/xlink'
 169    width='210mm'
 170    height='297mm'
 171    sodipodi:docbase='/tmp/'
 172    sodipodi:docname='/tmp/x'>
 173   <defs
 174      id='defs3' />
 175   <podi:namedview
 176      id='base' />
 177   <g transform='translate(10,10) scale (1.0)'>
 178   ")
 179
 180
 181
 182 ;; Interface functions
 183
 184 (define (sqr x)
 185   (* x x))
 186
 187 ;; transform=scale and stroke don't play nice together...
 188 (define (XXXbeam width slope thick)
 189   (let* ((x width)
 190          (y (* slope width))
 191          (z (sqrt (+ (sqr x) (sqr y)))))
 192     (tagify "rect" ""
 193             ;; '(style . "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:0.1;stroke-linejoin:miter;stroke-linecap:butt;")
 194             ;;'(style . "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-opacity:1;stroke-width:0.000001;stroke-linejoin:miter;stroke-linecap:butt;")
 195             `(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))
 196             ;;`(x . ,(number->string half-lt))
 197             `(x . "0")
 198             ;;`(y . ,(number->string (- half-lt (/ thick 2))))
 199             `(y . ,(number->string (- 0 (/ thick 2))))
 200             `(width . ,(number->string width))
 201             `(height . ,(number->string thick))
 202             `(ry . ,(number->string half-lt))
 203             `(transform . ,(format #f "matrix(~f,~f,0,1,0,0) scale (~f,~f)"
 204                                    (/ x z)
 205                                    (* -1 (/ y z))
 206                                    output-scale output-scale)))))
 207
 208 (define (beam width slope thick)
 209   (let* ((x width)
 210          (y (* slope width))
 211          (z (sqrt (+ (sqr x) (sqr y)))))
 212     (tagify "rect" ""
 213             `(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))
 214             `(x . "0")
 215             `(y . ,(number->string (* output-scale (- 0 (/ thick 2)))))
 216             `(width . ,(number->string (* output-scale width)))
 217             `(height . ,(number->string (* output-scale thick)))
 218             `(ry . ,(number->string (* output-scale half-lt)))
 219             `(transform . ,(format #f "matrix(~f,~f,0,1,0,0) scale (~f,~f)"
 220                                    (/ x z)
 221                                    (* -1 (/ y z))
 222                                    1 1)))))
 223
 224 ;; TODO: bezier-ending, see ps.scm
 225 (define (bezier-bow urg-l thick)
 226
 227   (define (bezier-ending z0 z1 z2)
 228     (let ((x0 (car z0))
 229           (y0 (cdr z0))
 230           (x1 (car z1))
 231           (y1 (cdr z1))
 232           (x2 (car z2))
 233           (y2 (cdr z2)))
 234       (let ((r (/ (sqrt (+ (* (- x1 x2) (- x1 x2))
 235                           (* (- y1 y2) (- y1 y2)))) 2)))
 236       (tagify "circle" ""
 237               `(fill . "#000000;")
 238               `(cx . ,(number->string (* output-scale x0)))
 239               `(cy . ,(number->string (* output-scale (- 0 y0))))
 240               `(r . ,(number->string (* output-scale r)))))))
 241
 242   (let ((l (eval urg-l this-module)))
 243     (string-append
 244      (bezier-sandwich l thick)
 245      (bezier-ending (list-ref l 3) (list-ref l 0) (list-ref l 5))
 246      (bezier-ending (list-ref l 7) (list-ref l 0) (list-ref l 5)))))
 247
 248 (define (bezier-sandwich l thick)
 249   (let* (;;(l (eval urg-l this-module))
 250          (first (list-tail l 4))
 251          (first-c0 (car (list-tail first 3)))
 252          (second (list-head l 4)))
 253     (tagify "path" ""
 254             `(stroke . "#000000")
 255             `(stroke-width . ,(number->string line-thickness))
 256             `(transform . ,(format #f "scale (~f,~f)"
 257                                    output-scale output-scale))
 258             `(d . ,(string-append (svg-bezier first #f)
 259                                   (svg-bezier second first-c0))))))
 260
 261 (define (char i)
 262   (if #t
 263       ;;(tagify "tspan" (format #f "&#xe0~2,'0x;" i))
 264       (tagify "tspan" (ascii->upm-string i))
 265       (begin
 266         (format #t "can't display char: ~x\n" i)
 267         " ")))
 268
 269
 270 (define (comment s)
 271   (string-append "<!-- " s " -->\n"))
 272
 273 (define (define-fonts internal-external-name-mag-pairs)
 274   (comment (format #f "Fonts used: ~S" internal-external-name-mag-pairs)))
 275
 276 (define (end-output)
 277   "</g></svg>")
 278
 279 ;;TODO
 280 ;(define (horizontal-line x1 x2 th)
 281 ;  (draw-line th x1  0 x2 0))
 282
 283 (define (filledbox breapth width depth height)
 284   (roundfilledbox breapth width depth height line-thickness))
 285
 286 (define font-cruft
 287   "fill:black;stroke:none;text-anchor:start;writing-mode:lr;font-weight:normal;")
 288
 289 ;; FIXME
 290 (define font-alist
 291   `(
 292     ("cmr8" . ,(string-append
 293                   font-cruft
 294                   "font-family:cmr;font-style:normal;font-size:8;"))
 295     ("feta13" . ,(string-append
 296                   font-cruft
 297                   "font-family:LilyPond-Feta;font-style:-Feta;font-size:13;"))
 298     ("feta-nummer10" . ,(string-append
 299                          font-cruft
 300                          "font-family:LilyPond-feta-nummer;font-style:-feta-nummer;font-size:10;"))
 301     ("feta20" . ,(string-append
 302                   font-cruft
 303                   "font-family:LilyPond-feta;font-style:-feta;font-size:20;"))
 304     ("parmesan20" . ,(string-append
 305                       font-cruft
 306                       "font-family:LilyPond-Parmesan;font-style:-Parmesan;font-size:20;"))))
 307
 308 (define (get-font name-mag-pair)
 309   ;; name-mag-pair: (quote ("feta20" . 0.569055118110236))"feta20"(quote ("feta20" . 0.569055118110236))
 310   (let ((f (assoc (caadr name-mag-pair) font-alist)))
 311     (if (pair? f)
 312         (cdr f)
 313         (begin
 314           (format #t "font not found: ~s\n" (caadr name-mag-pair))
 315           (cdr (assoc "feta20" font-alist))))))
 316
 317 (define (fontify name-mag-pair expr)
 318   (string-append
 319    (tagify "text" (dispatch expr) (cons 'style (get-font name-mag-pair)))))
 320
 321 (define (header-end)
 322   (comment "header-end"))
 323
 324 (define (header creator generate)
 325   (string-append
 326    xml-header
 327    (comment creator)
 328    (comment generate)
 329    svg-header))
 330
 331
 332 (define (lily-def key val)
 333   (cond
 334    ((equal? key "lilypondpaperoutputscale")
 335     ;; ugr
 336     ;; If we just use transform scale (output-scale),
 337     ;; all fonts come out scaled too (ie, much too big)
 338     ;; So, we manually scale all other stuff.
 339     (set! output-scale (* scale-to-unit (string->number val))))
 340    ((equal? key "lilypondpaperlinethickness")
 341     (set! urg-line-thickness (* scale-to-unit (string->number val)))))
 342   "")
 343
 344 (define (no-origin)
 345   "")
 346
 347
 348 (define (placebox x y expr)
 349   (tagify "g" (dispatch expr)
 350           `(transform .
 351                       ,(string-append
 352                         "translate("
 353                         ;; urg
 354                         (number->string (* output-scale x))
 355                         ","
 356                         (number->string (- 0 (* output-scale y)))
 357                         ")"))))
 358
 359 (define (roundfilledbox breapth width depth height blot-diameter)
 360   (tagify "rect" ""
 361           ;;'(style . "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;")
 362             `(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))
 363           `(x . ,(number->string (* output-scale (- 0 breapth))))
 364           `(y . ,(number->string (* output-scale (- 0 height))))
 365           `(width . ,(number->string (* output-scale (+ breapth width))))
 366           `(height . ,(number->string (* output-scale (+ depth height))))
 367           ;;`(ry . ,(number->string (* output-scale half-lt)))
 368           `(ry . ,(number->string (/ blot-diameter 2)))))
 369
 370
 371
 372 ;; TODO: use height, set scaling?
 373 (define (start-system width height)
 374   (let ((y system-y))
 375     ;;"<g transform='translate(50,-250)'>
 376     (set! system-y (+ system-y height))
 377     ;;(format #f "<g transform='translate(0,~1,'~f)'>" y)))
 378     (string-append
 379      "\n"
 380      (comment "start-system")
 381      (format #f "<g transform='translate(0.0,~f)'>\n" (* output-scale y)))))
 382
 383 (define (stop-system)
 384   (string-append
 385    "\n"
 386    (comment "stop-system")
 387    "</g>\n"))
 388
 389 (define stop-last-system stop-system)
 390
 391 (define (text s)
 392   ;; to unicode or not?
 393   (if #t
 394       (tagify "tspan" s)
 395       (tagify "tspan"
 396               (apply string-appendb
 397                      (map (lambda (x) (ascii->upm-string (char->integer x)))
 398                           (string->list s))))))