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 ;;;    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   <sodipodi: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
 225 (define (bezier-sandwich l thick)
 226   (let* (;;(l (eval urg-l this-module))
 227          (first (list-tail l 4))
 228          (first-c0 (car (list-tail first 3)))
 229          (second (list-head l 4)))
 230     (tagify "path" ""
 231             `(stroke . "#000000")
 232             `(stroke-width . ,(number->string line-thickness))
 233             `(transform . ,(format #f "scale (~f,~f)"
 234                                    output-scale output-scale))
 235             `(d . ,(string-append (svg-bezier first #f)
 236                                   (svg-bezier second first-c0))))))
 237
 238 (define (char i)
 239   (if #t
 240       ;;(tagify "tspan" (format #f "&#xe0~2,'0x;" i))
 241       (tagify "tspan" (ascii->upm-string i))
 242       (begin
 243         (format #t "can't display char: ~x\n" i)
 244         " ")))
 245
 246
 247 (define (comment s)
 248   (string-append "<!-- " s " -->\n"))
 249
 250 (define (define-fonts internal-external-name-mag-pairs)
 251   (comment (format #f "Fonts used: ~S" internal-external-name-mag-pairs)))
 252
 253 (define (end-output)
 254   "</g></svg>")
 255
 256 ;;TODO
 257 ;(define (horizontal-line x1 x2 th)
 258 ;  (draw-line th x1  0 x2 0))
 259
 260 (define (filledbox breapth width depth height)
 261   (round-filled-box breapth width depth height line-thickness))
 262
 263 (define font-cruft
 264   "fill:black;stroke:none;text-anchor:start;writing-mode:lr;font-weight:normal;")
 265
 266 ;; FIXME
 267 (define font-alist
 268   `(
 269     ("cmr8" . ,(string-append
 270                   font-cruft
 271                   "font-family:cmr;font-style:normal;font-size:8;"))
 272     ("feta13" . ,(string-append
 273                   font-cruft
 274                   "font-family:LilyPond-Feta;font-style:-Feta;font-size:13;"))
 275     ("feta-nummer10" . ,(string-append
 276                          font-cruft
 277                          "font-family:LilyPond-feta-nummer;font-style:-feta-nummer;font-size:10;"))
 278     ("feta20" . ,(string-append
 279                   font-cruft
 280                   "font-family:LilyPond-feta;font-style:-feta;font-size:20;"))
 281     ("parmesan20" . ,(string-append
 282                       font-cruft
 283                       "font-family:LilyPond-Parmesan;font-style:-Parmesan;font-size:20;"))))
 284
 285 (define (get-font name-mag-pair)
 286   ;; name-mag-pair: (quote ("feta20" . 0.569055118110236))"feta20"(quote ("feta20" . 0.569055118110236))
 287   (let ((f (assoc (caadr name-mag-pair) font-alist)))
 288     (if (pair? f)
 289         (cdr f)
 290         (begin
 291           (format #t "font not found: ~s\n" (caadr name-mag-pair))
 292           (cdr (assoc "feta20" font-alist))))))
 293
 294 (define (fontify name-mag-pair expr)
 295   (string-append
 296    (tagify "text" (dispatch expr) (cons 'style (get-font name-mag-pair)))))
 297
 298 (define (header-end)
 299   (comment "header-end"))
 300
 301 (define (header creator generate)
 302   (string-append
 303    xml-header
 304    (comment creator)
 305    (comment generate)
 306    svg-header))
 307
 308
 309 (define (lily-def key val)
 310   (cond
 311    ((equal? key "lilypondpaperoutputscale")
 312     ;; ugr
 313     ;; If we just use transform scale (output-scale),
 314     ;; all fonts come out scaled too (ie, much too big)
 315     ;; So, we manually scale all other stuff.
 316     (set! output-scale (* scale-to-unit (string->number val))))
 317    ((equal? key "lilypondpaperlinethickness")
 318     (set! urg-line-thickness (* scale-to-unit (string->number val)))))
 319   "")
 320
 321 (define (no-origin)
 322   "")
 323
 324
 325 (define (placebox x y expr)
 326   (tagify "g" (dispatch expr)
 327           `(transform .
 328                       ,(string-append
 329                         "translate("
 330                         ;; urg
 331                         (number->string (* output-scale x))
 332                         ","
 333                         (number->string (- 0 (* output-scale y)))
 334                         ")"))))
 335
 336 (define (round-filled-box breapth width depth height blot-diameter)
 337   (tagify "rect" ""
 338           ;;'(style . "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;")
 339             `(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))
 340           `(x . ,(number->string (* output-scale (- 0 breapth))))
 341           `(y . ,(number->string (* output-scale (- 0 height))))
 342           `(width . ,(number->string (* output-scale (+ breapth width))))
 343           `(height . ,(number->string (* output-scale (+ depth height))))
 344           ;;`(ry . ,(number->string (* output-scale half-lt)))
 345           `(ry . ,(number->string (/ blot-diameter 2)))))
 346
 347
 348
 349 ;; TODO: use height, set scaling?
 350 (define (start-system width height)
 351   (let ((y system-y))
 352     ;;"<g transform='translate(50,-250)'>
 353     (set! system-y (+ system-y height))
 354     ;;(format #f "<g transform='translate(0,~1,'~f)'>" y)))
 355     (string-append
 356      "\n"
 357      (comment "start-system")
 358      (format #f "<g transform='translate(0.0,~f)'>\n" (* output-scale y)))))
 359
 360 (define (stop-system)
 361   (string-append
 362    "\n"
 363    (comment "stop-system")
 364    "</g>\n"))
 365
 366 (define stop-last-system stop-system)
 367
 368 (define (text s)
 369   ;; to unicode or not?
 370   (if #t
 371       (tagify "tspan" s)
 372       (tagify "tspan"
 373               (apply string-appendb
 374                      (map (lambda (x) (ascii->upm-string (char->integer x)))
 375                           (string->list s))))))