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 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 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 ;; 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 (define (filledbox breapth width depth height)
 280   (roundfilledbox breapth width depth height line-thickness))
 281
 282 (define font-cruft
 283   "fill:black;stroke:none;text-anchor:start;writing-mode:lr;font-weight:normal;")
 284
 285 ;; FIXME
 286 (define font-alist
 287   `(
 288     ("cmr8" . ,(string-append
 289                   font-cruft
 290                   "font-family:cmr;font-style:normal;font-size:8;"))
 291     ("feta13" . ,(string-append
 292                   font-cruft
 293                   "font-family:LilyPond-Feta;font-style:-Feta;font-size:13;"))
 294     ("feta-nummer10" . ,(string-append
 295                          font-cruft
 296                          "font-family:LilyPond-feta-nummer;font-style:-feta-nummer;font-size:10;"))
 297     ("feta20" . ,(string-append
 298                   font-cruft
 299                   "font-family:LilyPond-feta;font-style:-feta;font-size:20;"))
 300     ("parmesan20" . ,(string-append
 301                       font-cruft
 302                       "font-family:LilyPond-Parmesan;font-style:-Parmesan;font-size:20;"))))
 303
 304 (define (get-font name-mag-pair)
 305   ;; name-mag-pair: (quote ("feta20" . 0.569055118110236))"feta20"(quote ("feta20" . 0.569055118110236))
 306   (let ((f (assoc (caadr name-mag-pair) font-alist)))
 307     (if (pair? f)
 308         (cdr f)
 309         (begin
 310           (format #t "font not found: ~s\n" (caadr name-mag-pair))
 311           (cdr (assoc "feta20" font-alist))))))
 312
 313 (define (fontify name-mag-pair expr)
 314   (string-append
 315    (tagify "text" (dispatch expr) (cons 'style (get-font name-mag-pair)))))
 316
 317 (define (header-end)
 318   (comment "header-end"))
 319
 320 (define (header creator generate)
 321   (string-append
 322    xml-header
 323    (comment creator)
 324    (comment generate)
 325    svg-header))
 326
 327
 328 (define (lily-def key val)
 329   (cond
 330    ((equal? key "lilypondpaperoutputscale")
 331     ;; ugr
 332     ;; If we just use transform scale (output-scale),
 333     ;; all fonts come out scaled too (ie, much too big)
 334     ;; So, we manually scale all other stuff.
 335     (set! output-scale (* scale-to-unit (string->number val))))
 336    ((equal? key "lilypondpaperlinethickness")
 337     (set! urg-line-thickness (* scale-to-unit (string->number val)))))
 338   "")
 339
 340 (define (no-origin)
 341   "")
 342
 343
 344 (define (placebox x y expr)
 345   (tagify "g" (dispatch expr)
 346           `(transform .
 347                       ,(string-append
 348                         "translate("
 349                         ;; urg
 350                         (number->string (* output-scale x))
 351                         ","
 352                         (number->string (- 0 (* output-scale y)))
 353                         ")"))))
 354
 355 (define (roundfilledbox breapth width depth height blot-diameter)
 356   (tagify "rect" ""
 357           ;;'(style . "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;")
 358             `(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))
 359           `(x . ,(number->string (* output-scale (- 0 breapth))))
 360           `(y . ,(number->string (* output-scale (- 0 height))))
 361           `(width . ,(number->string (* output-scale (+ breapth width))))
 362           `(height . ,(number->string (* output-scale (+ depth height))))
 363           ;;`(ry . ,(number->string (* output-scale half-lt)))
 364           `(ry . ,(number->string (/ blot-diameter 2)))))
 365
 366
 367
 368 ;; TODO: use height, set scaling?
 369 (define (start-system width height)
 370   (let ((y system-y))
 371     ;;"<g transform='translate(50,-250)'>
 372     (set! system-y (+ system-y height))
 373     ;;(format #f "<g transform='translate(0,~1,'~f)'>" y)))
 374     (string-append
 375      "\n"
 376      (comment "start-system")
 377      (format #f "<g transform='translate(0.0,~f)'>\n" (* output-scale y)))))
 378
 379 (define (stop-system)
 380   (string-append
 381    "\n"
 382    (comment "stop-system")
 383    "</g>\n"))
 384
 385 (define stop-last-system stop-system)
 386
 387 (define (text s)
 388   ;; to unicode or not?
 389   (if #t
 390       (tagify "tspan" s)
 391       (tagify "tspan"
 392               (apply string-appendb
 393                      (map (lambda (x) (ascii->upm-string (char->integer x)))
 394                           (string->list s))))))