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) 1998--2002 Jan Nieuwenhuizen <janneke@gnu.org>
   6
   7 ;;;; NOTE:
   8 ;;;;
   9 ;;;; * Get mftrace 1.0.12 or newer
  10 ;;;;
  11 ;;;; * Get sodipodi-cvs from 2002-11-23 or newer
  12 ;;;;
  13 ;;;; * Link/copy mf/out/private-fonts to ~/.sodipodi/private-fonts
  14
  15
  16
  17 (debug-enable 'backtrace)
  18
  19
  20 (define-module (scm sodipodi))
  21 (define this-module (current-module))
  22
  23 (use-modules
  24  (guile)
  25  (lily))
  26
  27
  28
  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
  54
  55 ;; Module entry
  56 ;;(define-public (sodipodi-output-expression expr port)
  57 ;;  (display (eval expr this-module) port))
  58
  59 (define-public (sodipodi-output-expression expr port)
  60   (display (dispatch expr) port))
  61
  62
  63 (define (dispatch expr)
  64   (let ((keyword (car expr)))
  65     (cond
  66      ((eq? keyword 'some-func) "")
  67      ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
  68      ;;((eq? keyword 'fontify) (dispatch (caddr expr)))
  69      (else
  70       (if (module-defined? this-module keyword)
  71           (apply (eval keyword this-module) (cdr expr))
  72           (begin
  73             (display
  74              (string-append "undefined: " (symbol->string keyword) "\n"))
  75             ""))))))
  76
  77
  78 ;; Global vars
  79
  80 (define output-scale 1)
  81 (define system-x 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 (* output-scale (car c))) ","
 129    (number->string (* -1 (* output-scale (cdr c)))) " "))
 130
 131 (define (control-flip-y c)
 132   (cons (car c) (* -1 (cdr c))))
 133
 134 (define (numbers->string l)
 135   (string-append
 136    (number->string (car l))
 137    (if (null? (cdr l))
 138        ""
 139        (string-append ","  (numbers->string (cdr l))))))
 140
 141 (define (svg-bezier l)
 142   (let* ((c0 (car (list-tail l 3)))
 143          (c123 (list-head l 3)))
 144     (string-append
 145      "M " (control->string c0)
 146      "C " (apply string-append (map control->string c123)))))
 147
 148
 149 (define xml-header
 150 "<?xml version='1.0' standalone='no'?>
 151 <!DOCTYPE svg PUBLIC '-//W3C//DTD SVG 20010904//EN'
 152 'http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd'
 153 [
 154  <!ATTLIST svg
 155  xmlns:xlink CDATA #FIXED 'http://www.w3.org/1999/xlink'>
 156 ]>
 157 "
 158 ;;"
 159 )
 160
 161 (define svg-header
 162 "<svg
 163    id='svg1'
 164    sodipodi:version='0.26'
 165    xmlns='http://www.w3.org/2000/svg'
 166    xmlns:sodipodi='http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd'
 167    xmlns:xlink='http://www.w3.org/1999/xlink'
 168    width='210mm'
 169    height='297mm'
 170    sodipodi:docbase='/tmp/'
 171    sodipodi:docname='/tmp/x'>
 172   <defs
 173      id='defs3' />
 174   <sodipodi:namedview
 175      id='base' />
 176   <g tranform='translate(50,-250)'>
 177   ")
 178
 179
 180
 181 ;; Interface functions
 182
 183 (define (sqr x)
 184   (* x x))
 185
 186 (define (beam width slope thick)
 187   (let* ((x width)
 188          (y (* slope width))
 189          (z (sqrt (+ (sqr x) (sqr y)))))
 190     (tagify "rect" ""
 191
 192           '(style . "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;")
 193           `(x . ,(number->string (* output-scale half-lt)))
 194           `(y . ,(number->string (* output-scale (- half-lt (/ thick 2)))))
 195           `(width . ,(number->string (* output-scale width)))
 196           `(height . ,(number->string (* output-scale thick)))
 197 ;;        `(ry . ,(number->string (* output-scale half-lt)))
 198           `(ry . ,(number->string line-thickness))
 199           `(transform . ,(format #f "matrix(~f,~f,0,1,0,0)"
 200                                  (/ x z)
 201                                  (* -1 (/ y z)))))))
 202
 203 ;; TODO: bezier-ending, see ps.scm
 204 (define (bezier-bow l thick)
 205   (bezier-sandwich l thick))
 206
 207 (define (bezier-sandwich l thick)
 208   (let* ((urg (eval l this-module))
 209          (first (list-tail urg 4))
 210          (second (list-head urg 4)))
 211     (string-append
 212      "<path\n"
 213      "style='stroke-width:"
 214      (number->string (* output-scale line-thickness)) ";'\n"
 215      "d='"
 216      (svg-bezier first)
 217      (svg-bezier second)
 218      "'/>\n")))
 219
 220 (define (char i)
 221   (if #t
 222       ;;(tagify "tspan" (format #f "&#xe0~2,'0x;" i))
 223       (tagify "tspan" (ascii->upm-string i))
 224       (begin
 225         (format #t "can't display char: ~x\n" i)
 226         " ")))
 227
 228
 229 (define (comment s)
 230   (string-append "<!-- " s " -->\n"))
 231
 232 (define (define-fonts internal-external-name-mag-pairs)
 233   (comment (format #f "Fonts used: ~S" internal-external-name-mag-pairs)))
 234
 235 (define (end-output)
 236   "</g></svg>")
 237
 238 (define (filledbox breapth width depth height)
 239   (roundfilledbox breapth width depth height line-thickness))
 240
 241 (define font-cruft
 242   "fill:black;stroke:none;font-style:normal;font-weight:normal;text-anchor:start;writing-mode:lr;")
 243
 244 ;; FIXME
 245 (define font-alist
 246   `(
 247     ("cmr8" . ,(string-append
 248                   font-cruft
 249                   "font-family:cmr;font-size:8;"))
 250     ("feta13" . ,(string-append
 251                   font-cruft
 252                   "font-family:LilyPond-Feta;font-size:13;"))
 253     ("feta-nummer10" . ,(string-append
 254                          font-cruft
 255                          "font-family:LilyPond-Feta-nummer;font-size:10;"))
 256     ("feta20" . ,(string-append
 257                   font-cruft
 258                   "font-family:LilyPond-Feta;font-size:20;"))
 259     ("parmesan20" . ,(string-append
 260                       font-cruft
 261                       "font-family:LilyPond-Parmesan;font-size:20;"))))
 262
 263 (define (get-font name-mag-pair)
 264   ;; name-mag-pair: (quote ("feta20" . 0.569055118110236))"feta20"(quote ("feta20" . 0.569055118110236))
 265   (let ((f (assoc (caadr name-mag-pair) font-alist)))
 266     (if (pair? f)
 267         (cdr f)
 268         (begin
 269           (format #t "font not found: ~s\n" (caadr name-mag-pair))
 270           (cdr (assoc "feta20" font-alist))))))
 271
 272 (define (fontify name-mag-pair expr)
 273   (string-append
 274    (tagify "text" (dispatch expr) (cons 'style (get-font name-mag-pair)))))
 275
 276 (define (header-end)
 277   (comment "header-end"))
 278
 279 (define (header creator generate)
 280   (string-append
 281    xml-header
 282    (comment creator)
 283    (comment generate)
 284    svg-header))
 285
 286
 287 (define (lily-def key val)
 288   (if (equal? key "lilypondpaperoutputscale")
 289       ;; ugr
 290       (set! output-scale (* scale-to-unit (string->number val))))
 291   "")
 292
 293 (define (no-origin)
 294   "")
 295
 296
 297 (define (placebox x y expr)
 298   (tagify "g" (dispatch expr)
 299           `(transform .
 300                       ,(string-append
 301                         "translate("
 302                         ;; urg
 303                         ;; (number->string (* output-scale x))
 304                         (number->string (* output-scale (+ system-x x)))
 305                         ","
 306                         ;; urg
 307                         ;; (number->string (- 0 (* output-scale y)))
 308                         (number->string (* output-scale (- system-y y)))
 309                         ")"))))
 310
 311 (define (roundfilledbox breapth width depth height blot-diameter)
 312   (tagify "rect" ""
 313
 314           '(style . "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;")
 315           `(x . ,(number->string (* output-scale (- 0 breapth))))
 316           `(y . ,(number->string (* output-scale (- 0 height))))
 317           `(width . ,(number->string (* output-scale (+ breapth width))))
 318           `(height . ,(number->string (* output-scale (+ depth height))))
 319           ;;`(ry . ,(number->string (* output-scale half-lt)))
 320           `(ry . ,(number->string blot-diameter))))
 321
 322
 323
 324 ;; TODO: use height, set scaling?
 325 (define (start-system width height)
 326   (let ((y system-y))
 327     ;;"<g tranform='translate(50,-250)'>
 328   (set! system-y (+ system-y height))
 329   ;;(format #f "<g tranform='translate(0,~1,'~f)'>" y)))
 330   (string-append
 331    "\n"
 332    (comment "start-system")
 333    (comment "URG, transform does not work!")
 334    (format #f "<g tranform='translate(0.0,~f)'>\n" (* output-scale y)))))
 335
 336 (define (stop-system)
 337   (string-append
 338    "\n"
 339    (comment "stop-system")
 340    "</g>\n"))
 341
 342 (define stop-last-system stop-system)
 343
 344 (define (text s)
 345   ;; to unicode or not?
 346   (if #t
 347       (tagify "tspan" s)
 348       (tagify "tspan"
 349               (apply string-appendb
 350                      (map (lambda (x) (ascii->upm-string (char->integer x)))
 351                           (string->list s))))))