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