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 that Sodipodi
   8 ;;;;
   9 ;;;;  * dumps core on displaying feta characters
  10 ;;;;  * needs PFBs (ie, not PFAs like sketch)
  11 ;;;;  * must have (LilyPond/feta) fonts registered through GNOME's
  12 ;;;;    gnome-font-install (ie, not through X11, like sketch and xfontsel),
  13 ;;;;    which in turn is very picky about afm files
  14 ;;;;  * has it's own svg-like language: possibly this file should be
  15 ;;;;    moved to svg.scm
  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
  83 (define scale-to-unit
  84   (cond
  85    ((equal? (ly:unit) "mm") (/ 72.0  25.4))
  86    ((equal? (ly:unit) "pt") (/ 72.0  72.27))
  87    (else (error "unknown unit" (ly:unit)))))
  88
  89 ;; alist containing fontname -> fontcommand assoc (both strings)
  90 ;;(define font-name-alist '())
  91
  92 ;; Helper functions
  93
  94
  95 (define (tagify tag string . attribute-alist)
  96   (string-append
  97    "<" tag
  98    (apply string-append (map (lambda (x) (string-append
  99                                           " "
 100                                           (symbol->string (car x))
 101                                           "='"
 102                                           (cdr x)
 103                                           "'"))
 104                              attribute-alist))
 105    ">\n"
 106    string "\n</" tag ">\n"))
 107
 108
 109 ;; Interface functions
 110
 111 (define (char i)
 112   (if (or
 113        #t
 114        (= i #x9)
 115        (= i #xa)
 116        (= i #xd)
 117        (>= i #x20))
 118       ;;(tagify "tspan" (format #f "&#x~2,'0x;" i))
 119       (tagify "tspan" (format #f "&#xe0~2,'0x;" i))
 120       ;; how to access remaining characters??
 121       ;;;(tagify "tspan" (format #f "&#x~2,'0x;" #x20)
 122       (begin
 123         (format #t "can't display char: ~x\n" i)
 124         " ")))
 125
 126 (define (end-output)
 127   "</g></svg>")
 128
 129
 130 (define (filledbox breapth width depth height)
 131   (tagify "rect" ""
 132
 133           '(style . "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;")
 134           `(x . ,(number->string (* output-scale (- 0 breapth))))
 135           `(y . ,(number->string (* output-scale (- 0 height))))
 136           `(width . ,(number->string (* output-scale (+ breapth width))))
 137           `(height . ,(number->string (* output-scale (+ depth height))))))
 138
 139
 140 (define font-alist '(("feta13" . ("LilyPond-Feta13" . "13"))
 141                      ("feta20" . "fill:black;stroke:none;font-family:lilypond;font-style:feta;font-weight:normal;font-size:20;fill-opacity:1;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;text-anchor:start;writing-mode:lr;")
 142                      ("parmesan20" . "fill:black;stroke:none;font-family:lilypond;font-style:parmesan;font-weight:normal;font-size:20;fill-opacity:1;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;text-anchor:start;writing-mode:lr;")
 143                      ))
 144 (define (get-font name-mag-pair)
 145   ;; name-mag-pair: (quote ("feta20" . 0.569055118110236))"feta20"(quote ("feta20" . 0.569055118110236))
 146   (let ((f (assoc (caadr name-mag-pair) font-alist)))
 147     (if (pair? f)
 148         (cdr f)
 149         (begin
 150           (format #t "font not found: ~s\n" (caadr name-mag-pair))
 151           (cdr (assoc "feta20" font-alist))))))
 152
 153 (define (fontify name-mag-pair expr)
 154   (string-append
 155    (tagify "text" (dispatch expr) (cons 'style (get-font name-mag-pair)))))
 156
 157
 158 (define (header creator generate)
 159 "<?xml version='1.0' standalone='no'?>
 160 <!DOCTYPE svg PUBLIC '-//W3C//DTD SVG 20010904//EN'
 161 'http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd'
 162 [
 163  <!ATTLIST svg
 164  xmlns:xlink CDATA #FIXED 'http://www.w3.org/1999/xlink'>
 165 ]>
 166 <!-- Created with Sodipodi ('http://www.sodipodi.com/') -->
 167 <svg
 168    id='svg1'
 169    sodipodi:version='0.26'
 170    xmlns='http://www.w3.org/2000/svg'
 171    xmlns:sodipodi='http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd'
 172    xmlns:xlink='http://www.w3.org/1999/xlink'
 173    width='210mm'
 174    height='297mm'
 175    sodipodi:docbase='/tmp/'
 176    sodipodi:docname='/tmp/x'>
 177   <defs
 178      id='defs3' />
 179   <sodipodi:namedview
 180      id='base' />
 181   <g tranform='translate(50,-250)'>
 182   ")
 183
 184
 185 (define (placebox x y expr)
 186   (tagify "g" (dispatch expr) `(transform .
 187                                           ,(string-append
 188                                             "translate(" (number->string
 189                                                           (* output-scale x))
 190                                             ","
 191                                             (number->string (- 0 (* output-scale y)))
 192                                             ")"))))
 193
 194 (define (lily-def key val)
 195   (if (equal? key "lilypondpaperoutputscale")
 196       ;; ugr
 197       (set! output-scale (* scale-to-unit (string->number val))))
 198   "")
 199
 200