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