+2004-11-16 Jan Nieuwenhuizen <janneke@gnu.org>
+
+ * scm/framework-svg.scm:
+ * scm/output-svg.scm: New file. TODO: figure out how to
+ do character by index in font.
+
+ * scm/output-sodipodi.scm: Remove.
+
+ * scm/output-ps.scm (stem): Remove.
+
+2004-11-15 Jan Nieuwenhuizen <janneke@gnu.org>
+
+ * scm/output-gnome.scm (beam): New function.
+ (slur): Round corners.
+ (round-filled-box): Round corners.
+
2004-11-16 Han-Wen Nienhuys <hanwen@xs4all.nl>
* scm/output-gnome.scm (beam): add function.
determine_output_options ()
{
bool found_gnome = false;
+ bool found_svg = false;
bool found_tex = false;
SCM formats = ly_output_formats ();
for (SCM s = formats; scm_is_pair (s); s = scm_cdr (s))
{
- found_tex = found_tex || (ly_scm2string (scm_car (s)) == "tex");
found_gnome = found_gnome || ly_scm2string(scm_car (s)) == "gnome";
+ found_svg = found_gnome || ly_scm2string(scm_car (s)) == "svg";
+ found_tex = found_tex || (ly_scm2string (scm_car (s)) == "tex");
}
if (make_pdf || make_png)
make_tex = true;
}
if (!found_gnome
+ && !found_svg
&& !(make_dvi
|| make_tex
|| make_ps
}
}
-void init_global_tweak_registry();
+void init_global_tweak_registry ();
static void
main_with_guile (void *, int, char **)
(define PANELS-HEIGHT 80)
(define PIXELS-PER-UNIT 2)
+;; 2.5??
(define OUTPUT-SCALE (* 2.5 PIXELS-PER-UNIT))
(define-public output-scale OUTPUT-SCALE)
--- /dev/null
+;;;; framework-svg.scm --
+;;;;
+;;;; source file of the GNU LilyPond music typesetter
+;;;;
+;;;; (c) 2004 Jan Nieuwenhuizen <janneke@gnu.org>
+
+(define-module (scm framework-svg))
+
+(use-modules (guile) (lily))
+(use-modules (srfi srfi-2) (ice-9 regex))
+
+;; FIXME: 0.62 to get paper size right
+(define output-scale (* 0.62 scale-to-unit))
+
+(define-public (output-framework outputter book scopes fields basename)
+ (let* ((paper (ly:paper-book-paper book))
+ (pages (ly:paper-book-pages book))
+ (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t))
+ (page-number (1- (ly:output-def-lookup paper 'firstpagenumber)))
+ (page-count (length pages))
+ (hsize (ly:output-def-lookup paper 'hsize))
+ (vsize (ly:output-def-lookup paper 'vsize))
+ (page-width (inexact->exact (ceiling (* output-scale hsize))))
+ (page-height (inexact->exact (ceiling (* output-scale vsize)))))
+
+ (ly:outputter-dump-string outputter xml-header)
+ (ly:outputter-dump-string
+ outputter
+ (comment "Created with GNU LilyPond (http://lilypond.org)"))
+ (ly:outputter-dump-string
+ outputter (format #f "<svg id='svg1' width='~smm' height='~smm'>\n"
+ page-width page-height))
+ (ly:outputter-dump-string
+ outputter "<g transform='translate (10, 10) scale (1)'>\n")
+
+; (for-each
+; (lambda (x)
+; (ly:outputter-dump-string outputter x))
+; (cons
+; (page-header paper page-count)
+; (preamble paper)))
+
+ (for-each
+ (lambda (page)
+ (set! page-number (1+ page-number))
+ (dump-page outputter page page-number page-count landscape?))
+ pages)
+ (ly:outputter-dump-string outputter "\n</g>\n</svg>\n")))
+
+(define (comment s)
+ (string-append "<!-- " s " !-->\n"))
+
+;; FIXME: gulp from file
+(define xml-header
+ "<?xml version='1.0' encoding='UTF-8' standalone='no'?>
+<!DOCTYPE svg PUBLIC '-//W3C//DTD SVG 20010904//EN'
+'http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd'>
+")
+
+(define (dump-page outputter page page-number page-count landscape?)
+ (ly:outputter-dump-string
+ outputter
+ (string-append
+ (comment (format #f "Page: ~S/~S" page-number page-count))
+ ;;(format #f "<g transform='translate (0, ~f)'>\n" (* output-scale y))))
+ "<g>\n"))
+
+ ;; FIXME:landscape
+ (ly:outputter-dump-stencil outputter page)
+
+ (ly:outputter-dump-string
+ outputter
+ (string-append
+ (comment (format #f "End Page ~S/~S" page-number page-count))
+ "</g>\n")))
+;;;; lily-library.scm -- utilities
+;;;;
+;;;; source file of the GNU LilyPond music typesetter
+;;;;
+;;;; (c) 1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
(define-public X 0)
(not (= l r)))
+(define-public scale-to-unit
+ (cond
+ ((equal? (ly:unit) "mm") (/ 72.0 25.4))
+ ((equal? (ly:unit) "pt") (/ 72.0 72.27))
+ (else (error "unknown unit" (ly:unit)))))
+
-;;;; lily.scm -- implement Scheme output routines for TeX and PostScript
+;;;; lily.scm -- toplevel Scheme stuff
;;;;
;;;; source file of the GNU LilyPond music typesetter
;;;;
;;;; (c) 1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
-;;; Library functions
-
(if (defined? 'set-debug-cell-accesses!)
(set-debug-cell-accesses! #f))
;;; * Build LilyPond with gui support: configure --enable-gui
;;;
;;; * Supposing that LilyPond was built in ~/cvs/savannah/lilypond,
-;;; tell fontconfig about the feta fonts dir:
+;;; tell fontconfig about the feta fonts dir and run fc-cache
"
cat > ~/.fonts.conf << EOF
<fontconfig>
<dir>/usr/share/texmf/fonts/type1/public/ec-fonts-mftraced</dir>
</fontconfig>
EOF
+fc-cache
"
;;; or copy all your .pfa/.pfb's to ~/.fonts if your fontconfig
;;; already looks there for fonts. Check if it works by doing:
(define (char->utf8-string char)
(list->string (utf8 (char->integer char))))
-(define (draw-rectangle x1 y1 x2 y2 color width-units)
- (make <gnome-canvas-rect>
- #:parent (canvas-root) #:x1 x1 #:y1 y1 #:x2 x2 #:y2 y2
- #:fill-color color #:width-units width-units))
-
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; stencil outputters
;;;
(ly:all-stencil-expressions)
(ly:all-output-backend-commands)))
+(define (beam width slope thick blot)
+ (define cursor '(0 . 0))
+ (define (rmoveto def x y)
+ (set! cursor (cons (+ x (car cursor)) (+ y (cdr cursor))))
+ (moveto def (car cursor) (cdr cursor)))
+ (define (rlineto def x y)
+ (set! cursor (cons (+ x (car cursor)) (+ y (cdr cursor))))
+ (lineto def (car cursor) (cdr cursor)))
+ (let* ((def (make <gnome-canvas-path-def>))
+ (bezier (make <gnome-canvas-bpath>
+ #:parent (canvas-root)
+ #:fill-color "black"
+ #:outline-color "black"
+ #:width-units blot
+ #:join-style 'round))
+ (t (- thick blot))
+ (w (- width blot))
+ (h (* w slope)))
+
+ (reset def)
+ (rmoveto def (/ blot 2) (/ t 2))
+ (rlineto def w (- h))
+ (rlineto def 0 (- t))
+ (rlineto def (- w) h)
+ (rlineto def 0 t)
+ (closepath def)
+ (set-path-def bezier def)
+ bezier))
+
+(define (square-beam width slope thick blot)
+ (let*
+ ((def (make <gnome-canvas-path-def>))
+ (y (* (- width) slope))
+ (props (make <gnome-canvas-bpath>
+ #:parent (canvas-root)
+ #:fill-color "black"
+ #:outline-color "black"
+ #:width-units 0.0)))
+
+ (reset def)
+ (moveto def 0 0)
+ (lineto def width y)
+ (lineto def width (- y thick))
+ (lineto def 0 (- thick))
+ (lineto def 0 0)
+ (closepath def)
+ (set-path-def props def)
+ props))
+
+
;; two beziers
(define (bezier-sandwich lst thick)
(let* ((def (make <gnome-canvas-path-def>))
#:parent (canvas-root)
#:fill-color "black"
#:outline-color "black"
- #:width-units thick)))
+ #:width-units thick
+ #:join-style 'round)))
(reset def)
-
+
+ ;; FIXME: LST is pre-mangled for direct ps stack usage
;; cl cr r l 0 1 2 3
;; cr cl l r 4 5 6 7
(define (char font i)
(text font (utf8 i)))
+;; FIXME: naming
+(define (filledbox breapth width depth height)
+ (make <gnome-canvas-rect>
+ #:parent (canvas-root)
+ #:x1 (- breapth) #:y1 depth #:x2 width #:y2 (- height)
+ #:fill-color "black"
+ #:join-style 'miter))
+
+(define (grob-cause grob)
+ grob)
+
+;; WTF is this in every backend?
+(define (horizontal-line x1 x2 thickness)
+ (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness)))
+
(define (placebox x y expr)
(debugf "item: ~S\n" expr)
(let ((item expr))
item)
#f)))
-(define (beam width slope thick blot)
- (let*
- ((def (make <gnome-canvas-path-def>))
- (y (* (- width) slope))
- (props (make <gnome-canvas-bpath>
- #:parent (canvas-root)
- #:fill-color "black"
- #:outline-color "black"
- #:width-units 0.0)))
-
- (reset def)
- (moveto def 0 0)
- (lineto def width y)
- (lineto def width (- y thick))
- (lineto def 0 (- thick))
- (lineto def 0 0)
- (closepath def)
- (set-path-def props def)
- props))
-
-
(define (dashed-line thick on off dx dy)
(draw-line thick 0 0 dx dy))
(define (round-filled-box breapth width depth height blot-diameter)
- ;; FIXME: no rounded corners on rectangle...
- ;; FIXME: blot?
- (draw-rectangle (- breapth) depth width (- height) "black" blot-diameter))
-
-(define (pango-font-name font)
- (let ((name (ly:font-name font)))
- (if name
- (regexp-substitute/global #f "^GNU-(.*)-[.0-9]*$" name 'pre 1 'post)
- (begin
- (stderr "font-name: ~S\n" (ly:font-name font))
- ;; TODO s/filename/file-name/
- (stderr "font-filename: ~S\n" (ly:font-filename font))
- (stderr "pango-font-size: ~S\n" (pango-font-size font))
- "ecrm12"))))
-
-(define (pango-font-size font)
- (let* ((designsize (ly:font-design-size font))
- (magnification (* (ly:font-magnification font)))
-
- ;; experimental sizing:
- ;; where does factor come from?
- ;;
- ;; 0.435 * (12 / 20) = 0.261
- ;; 2.8346456692913/ 0.261 = 10.86071137659501915708
- ;;(ops (* 0.435 (/ 12 20) (* output-scale pixels-per-unit)))
- ;; for size-points
- (ops 2.61)
-
- (scaling (* ops magnification designsize)))
- (debugf "OPS:~S\n" ops)
- (debugf "scaling:~S\n" scaling)
- (debugf "magnification:~S\n" magnification)
- (debugf "design:~S\n" designsize)
-
- scaling))
-
-;;font-name: "GNU-LilyPond-feta-20"
-;;font-filename: "feta20"
-;;pango-font-name: "lilypond-feta, regular 32"
-;;OPS:2.61
-;;scaling:29.7046771653543
-;;magnification:0.569055118110236
-;;design:20.0
+ (let ((r (/ blot-diameter 2)))
+ (make <gnome-canvas-rect>
+ #:parent (canvas-root)
+ #:x1 (- r breapth) #:y1 (- depth r) #:x2 (- width r) #:y2 (- r height)
+ #:fill-color "black"
+ #:outline-color "black"
+ #:width-units blot-diameter
+ #:join-style 'round)))
(define (text font string)
+ (define (pango-font-name font)
+ (let ((name (ly:font-name font)))
+ (if name
+ (regexp-substitute/global #f "^GNU-(.*)-[.0-9]*$" name 'pre 1 'post)
+ (begin
+ (stderr "font-name: ~S\n" (ly:font-name font))
+ ;; TODO s/filename/file-name/
+ (stderr "font-filename: ~S\n" (ly:font-filename font))
+ (stderr "pango-font-size: ~S\n" (pango-font-size font))
+ "ecrm12"))))
+
+ (define (pango-font-size font)
+ (let* ((designsize (ly:font-design-size font))
+ (magnification (* (ly:font-magnification font)))
+
+
+ ;;font-name: "GNU-LilyPond-feta-20"
+ ;;font-filename: "feta20"
+ ;;pango-font-name: "lilypond-feta, regular 32"
+ ;;OPS:2.61
+ ;;scaling:29.7046771653543
+ ;;magnification:0.569055118110236
+ ;;design:20.0
+
+ ;; experimental sizing:
+ ;; where does factor come from?
+ ;;
+ ;; 0.435 * (12 / 20) = 0.261
+ ;; 2.8346456692913/ 0.261 = 10.86071137659501915708
+ ;;(ops (* 0.435 (/ 12 20) (* output-scale pixels-per-unit)))
+ ;; for size-points
+ (ops 2.61)
+
+ (scaling (* ops magnification designsize)))
+ (debugf "OPS:~S\n" ops)
+ (debugf "scaling:~S\n" scaling)
+ (debugf "magnification:~S\n" magnification)
+ (debugf "design:~S\n" designsize)
+
+ scaling))
+
(make <gnome-canvas-text>
#:parent (canvas-root)
(string->utf8-string string)
(char->utf8-string (car string)))))
-(define (filledbox a b c d)
- (round-filled-box a b c d 0.001))
-
-;; WTF is this in every backend?
-(define (horizontal-line x1 x2 thickness)
- (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness)))
-
-;;(define (define-origin file line col)
-;; (if (procedure? point-and-click)
-;; (list 'location line col file)))
-
-(define (grob-cause grob)
- grob)
(ly:numbers->string
(list x y width height blotdiam)) " draw_round_box"))
-
-(define (stem breapth width depth height) ; FIXME: use draw_round_box.
- (string-append
- (ly:numbers->string (list breapth width depth height))
- " draw_box" ))
-
-
(define (text font s)
(let*
+++ /dev/null
-;;;; sodipodi.scm -- implement Scheme output routines for PostScript
-;;;;
-;;;; source file of the GNU LilyPond music typesetter
-;;;;
-;;;; (c) 2002--2004 Jan Nieuwenhuizen <janneke@gnu.org>
-
-;;;; NOTE:
-;;;;
-;;;; * Get mftrace 1.0.12 or newer to create the .pfa fonts:
-;;;;
-;;;; make -C mf clean
-;;;; make -C mf pfa
-;;;;
-;;;; * Get sodipodi-0.28 or newer
-;;;;
-;;;; * Link/copy mf/out/private-fonts to ~/.sodipodi/private-fonts
-
-;;;; http://www.w3.org/TR/SVG11/paths.html
-
-
-(debug-enable 'backtrace)
-
-(define-module (scm output-sodipodi))
-(define this-module (current-module))
-
-(use-modules
- (guile)
- (lily))
-
-;;; Lily output interface --- cleanup and docme
-
-;;; Bare minimum interface for \score { \notes c } }
-;;; should implement:
-;;;
-;;; xx-output-expression
-;;; char
-;;; filledbox
-;;; placebox
-
-;;; and should intercept:
-;;;
-;;; lily-def
-;;; header-end
-;;; define-fonts
-;;; no-origin
-;;; start-system
-;;; header
-;;; comment
-;;; stop-last-system
-
-;; Module entry
-;;(define-public (sodipodi-output-expression expr port)
-;; (display (eval expr this-module) port))
-
-(define-public (sodipodi-output-expression expr port)
- (display (dispatch expr) port))
-
-(define (dispatch expr)
- (let ((keyword (car expr)))
- (cond
- ((eq? keyword 'some-func) "")
- ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
- (else
- (if (module-defined? this-module keyword)
- (apply (eval keyword this-module) (cdr expr))
- (begin
- (display
- (string-append "undefined: " (symbol->string keyword) "\n"))
- ""))))))
-
-
-;; Global vars
-
-;;; Global vars
-(define page-count 0)
-(define page-number 0)
-
-;;(define output-scale 2.83464566929134)
-(define output-scale (* 2 2.83464566929134))
-(define system-y 0)
-;; huh?
-(define urg-line-thickness 0)
-(define line-thickness 0.001)
-(define half-lt (/ line-thickness 2))
-
-
-(define scale-to-unit
- (cond
- ((equal? (ly:unit) "mm") (/ 72.0 25.4))
- ((equal? (ly:unit) "pt") (/ 72.0 72.27))
- (else (error "unknown unit" (ly:unit)))))
-
-;; Helper functions
-(define (tagify tag string . attribute-alist)
- (string-append
- "<" tag
- (apply string-append (map (lambda (x) (string-append
- " "
- (symbol->string (car x))
- "='"
- (cdr x)
- "'"))
- attribute-alist))
- ">\n"
- string "\n</" tag ">\n"))
-
-
-(define (ascii->string i) (make-string 1 (integer->char i)))
-(define (ascii->upm-string i)
- (let* ((i+1 (+ i 1))
- (u1 #xee)
- (u2 (+ #x80 (quotient i+1 #x40)))
- (u3 (+ #x80 (modulo i+1 #x40))))
- (apply string-append
- (map ascii->string
- (list u1 u2 u3)))))
-
-(define (control->list c)
- (list (car c) (cdr c)))
-
-(define (control->string c)
- (string-append
- (number->string (car c)) ","
- ;; loose the -1
- (number->string (* -1 (cdr c))) " "))
-
-(define (control-flip-y c)
- (cons (car c) (* -1 (cdr c))))
-
-(define (ly:numbers->string l)
- (string-append
- (number->string (car l))
- (if (null? (cdr l))
- ""
- (string-append "," (ly:numbers->string (cdr l))))))
-
-(define (svg-bezier l close)
- (let* ((c0 (car (list-tail l 3)))
- (c123 (list-head l 3)))
- (string-append
- (if (not close) "M " "L ")
- (control->string c0)
- "C " (apply string-append (map control->string c123))
- (if (not close) "" (string-append
- "L " (control->string close))))));; " Z")))))
-
-(define xml-header
-"<?xml version='1.0' standalone='no'?>
-<!DOCTYPE svg PUBLIC '-//W3C//DTD SVG 20010904//EN'
-'http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd'
-[
- <!ATTLIST svg
- xmlns:xlink CDATA #FIXED 'http://www.w3.org/1999/xlink'>
-]>
-"
-;;"
-)
-
-(define svg-header
-"<svg
- id='svg1'
- sodipodi:version='0.26'
- xmlns='http://www.w3.org/2000/svg'
- xmlns:sodipodi='http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd'
- xmlns:xlink='http://www.w3.org/1999/xlink'
- width='210mm'
- height='297mm'
- sodipodi:docbase='/tmp/'
- sodipodi:docname='/tmp/x'>
- <defs
- id='defs3' />
- <sodipodi:namedview
- id='base' />
- <g transform='translate(10,10) scale (1.0)'>
- ")
-
-
-
-;; Interface functions
-
-(define (sqr x)
- (* x x))
-
-;; transform=scale and stroke don't play nice together...
-(define (XXXbeam width slope thick)
- (let* ((x width)
- (y (* slope width))
- (z (sqrt (+ (sqr x) (sqr y)))))
- (tagify "rect" ""
- ;; '(style . "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:0.1;stroke-linejoin:miter;stroke-linecap:butt;")
- ;;'(style . "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-opacity:1;stroke-width:0.000001;stroke-linejoin:miter;stroke-linecap:butt;")
- `(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))
- ;;`(x . ,(number->string half-lt))
- `(x . "0")
- ;;`(y . ,(number->string (- half-lt (/ thick 2))))
- `(y . ,(number->string (- 0 (/ thick 2))))
- `(width . ,(number->string width))
- `(height . ,(number->string thick))
- `(ry . ,(number->string half-lt))
- `(transform . ,(format #f "matrix(~f,~f,0,1,0,0) scale (~f,~f)"
- (/ x z)
- (* -1 (/ y z))
- output-scale output-scale)))))
-
-(define (beam width slope thick)
- (let* ((x width)
- (y (* slope width))
- (z (sqrt (+ (sqr x) (sqr y)))))
- (tagify "rect" ""
- `(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))
- `(x . "0")
- `(y . ,(number->string (* output-scale (- 0 (/ thick 2)))))
- `(width . ,(number->string (* output-scale width)))
- `(height . ,(number->string (* output-scale thick)))
- `(ry . ,(number->string (* output-scale half-lt)))
- `(transform . ,(format #f "matrix(~f,~f,0,1,0,0) scale (~f,~f)"
- (/ x z)
- (* -1 (/ y z))
- 1 1)))))
-
-
-(define (bezier-sandwich l thick)
- (let* (;;(l (eval urg-l this-module))
- (first (list-tail l 4))
- (first-c0 (car (list-tail first 3)))
- (second (list-head l 4)))
- (tagify "path" ""
- `(stroke . "#000000")
- `(stroke-width . ,(number->string line-thickness))
- `(transform . ,(format #f "scale (~f,~f)"
- output-scale output-scale))
- `(d . ,(string-append (svg-bezier first #f)
- (svg-bezier second first-c0))))))
-
-(define (char font i)
- (tagify "tspan"
- (dispatch `(fontify ,font ,(ascii->upm-string i)))))
-
-(define (nchar font i)
- (format (current-error-port) "can't display char: ~x\n" i)
- " ")
-
-(define (comment s)
- (string-append "<!-- " s " -->\n"))
-
-(define (define-fonts layout font-list)
- (comment (format #f "Fonts used: ~S" font-list)))
-
-(define (filledbox breapth width depth height)
- (round-filled-box breapth width depth height line-thickness))
-
-(define font-cruft
- "fill:black;stroke:none;text-anchor:start;writing-mode:lr;font-weight:normal;")
-
-;; FIXME
-(define font-alist
- `(
- ("cmr8" . ,(string-append
- font-cruft
- "font-family:cmr;font-style:normal;font-size:8;"))
- ("ecrm10" . ,(string-append
- font-cruft
- "font-family:ecmr;font-style:normal;font-size:10;"))
- ("feta13" . ,(string-append
- font-cruft
- "font-family:LilyPond-Feta;font-style:-Feta;font-size:13;"))
- ("feta-nummer10" . ,(string-append
- font-cruft
- "font-family:LilyPond-feta-nummer;font-style:-feta-nummer;font-size:10;"))
- ("feta20" . ,(string-append
- font-cruft
- "font-family:LilyPond-feta;font-style:-feta;font-size:20;"))
- ("parmesan20" . ,(string-append
- font-cruft
- "font-family:LilyPond-Parmesan;font-style:-Parmesan;font-size:20;"))))
-
-(define (get-font font)
- (let* ((name (ly:font-filename font))
- (magnify (ly:font-magnification font)))
- ;; name-mag-pair: (quote ("feta20" . 0.569055118110236))"feta20"(quote ("feta20" . 0.569055118110236))
- (let ((font-string (assoc-get name font-alist)))
- (if (not font-string)
- (begin
- (format #t "font not found: ~S\n" font)
- (cdr (assoc "feta20" font-alist)))
- font-string))))
-
-(define (header-end)
- (comment "header-end"))
-
-(define (header creator time-stamp layout page-count- classic?)
- (string-append
- xml-header
- (comment creator)
- (comment time-stamp)
- svg-header))
-
-;; FIXME: duplicated in other output backends
-;; FIXME: silly interface name
-(define (output-scopes layout scopes fields basename)
- (format (current-error-port) "TODO: FIX ps/tex/interface\n"))
-
-;; FIXME: duplictates output-scopes, duplicated in other backends
-;; FIXME: silly interface name
-(define (output-layout-def pd)
- (format (current-error-port) "TODO: FIX ps/tex/interface\n"))
-
-(define (lily-def key val)
- (cond
- ((equal? key "lilypondpaperoutputscale")
- ;; ugr
- ;; If we just use transform scale (output-scale),
- ;; all fonts come out scaled too (ie, much too big)
- ;; So, we manually scale all other stuff.
- (set! output-scale (* scale-to-unit (string->number val))))
- ((equal? key "lilypondpaperlinethickness")
- (set! urg-line-thickness (* scale-to-unit (string->number val)))))
- "")
-
-(define (no-origin)
- "")
-
-
-(define (placebox x y expr)
- (tagify "g"
- ;; FIXME -- JCN
- ;;(dispatch expr)
- expr
- `(transform .
- ,(string-append
- "translate("
- ;; urg
- (number->string (* output-scale x))
- ","
- (number->string (- 0 (* output-scale y)))
- ")"))))
-
-(define (round-filled-box breapth width depth height blot-diameter)
- (tagify "rect" ""
- ;;'(style . "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;")
- `(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))
- `(x . ,(number->string (* output-scale (- 0 breapth))))
- `(y . ,(number->string (* output-scale (- 0 height))))
- `(width . ,(number->string (* output-scale (+ breapth width))))
- `(height . ,(number->string (* output-scale (+ depth height))))
- ;;`(ry . ,(number->string (* output-scale half-lt)))
- `(ry . ,(number->string (/ blot-diameter 2)))))
-
-
-
-;; TODO: use height, set scaling?
-(define (start-system origin dim)
-;;(define (start-system width height)
- (let ((y system-y))
- (set! system-y (+ system-y (cdr dim)))
- (string-append
- "\n"
- (comment "start-system")
- (format #f "<g transform='translate(0.0,~f)'>\n" (* output-scale y)))))
-
-(define (stop-system last?)
- (string-append
- "\n"
- (comment "stop-system")
- "</g>\n"))
-
-(define (fontify font expr)
- (string-append
-;; (tagify "text" (dispatch expr) (cons 'style (get-font font)))))
- (tagify "text" expr (cons 'style (get-font font)))))
-
-(define (text font s)
- (tagify "tspan"
- (apply string-append
- (map (lambda (x) (ascii->upm-string (char->integer x)))
- (string->list s)))
- (cons 'style (get-font font))))
-
-(define (ntext font s)
- ;; (fontify font
- ;; to unicode or not?
- (tagify "tspan" (dispatch `(fontify ,font ,s))))
-
-(define (start-page)
- (set! page-number (+ page-number 1))
- (comment "start-page"))
-
-(define (stop-page last?)
- (comment "stop-page"))
-
-;; WTF is this in every backend?
-(define (horizontal-line x1 x2 th)
-;; (draw-line th x1 0 x2 0))
- (filledbox (- x1) (- x2 x1) (* .5 th) (* .5 th)))
-
--- /dev/null
+;;;; output-svg.scm -- implement Scheme output routines for SVG1
+;;;;
+;;;; source file of the GNU LilyPond music typesetter
+;;;;
+;;;; (c) 2002--2004 Jan Nieuwenhuizen <janneke@gnu.org>
+
+;;;; http://www.w3.org/TR/SVG11/paths.html
+
+
+;;; TODO: character selects by index from [custom] fonts
+
+(debug-enable 'backtrace)
+(define-module (scm output-svg))
+(define this-module (current-module))
+
+(use-modules
+ (guile)
+ (ice-9 regex)
+ (lily))
+
+;; GLobals
+;; FIXME: 2?
+(define output-scale (* 2 scale-to-unit))
+(define line-thickness 0)
+
+(define (stderr string . rest)
+ (apply format (cons (current-error-port) (cons string rest)))
+ (force-output (current-error-port)))
+
+(define (debugf string . rest)
+ (if #f
+ (apply stderr (cons string rest))))
+
+
+(define (dispatch expr)
+ (let ((keyword (car expr)))
+ (cond
+ ((eq? keyword 'some-func) "")
+ ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
+ (else
+ (if (module-defined? this-module keyword)
+ (apply (eval keyword this-module) (cdr expr))
+ (begin
+ (display
+ (string-append "undefined: " (symbol->string keyword) "\n"))
+ ""))))))
+
+;; Helper functions
+(define (tagify tag string . attribute-alist)
+ (string-append
+ "<"
+ tag
+ (apply string-append
+ (map (lambda (x)
+ (string-append " " (symbol->string (car x)) "='" (cdr x) "'"))
+ attribute-alist))
+ ">"
+ string "</" tag ">\n"))
+
+(define (control->list c)
+ (list (car c) (cdr c)))
+
+(define (control->string c)
+ (string-append
+ (number->string (car c)) ","
+ ;; lose the -1
+ (number->string (* -1 (cdr c))) " "))
+
+(define (control-flip-y c)
+ (cons (car c) (* -1 (cdr c))))
+
+(define (ly:numbers->string l)
+ (string-append
+ (number->string (car l))
+ (if (null? (cdr l))
+ ""
+ (string-append "," (ly:numbers->string (cdr l))))))
+
+(define (svg-bezier l close)
+ (let* ((c0 (car (list-tail l 3)))
+ (c123 (list-head l 3)))
+ (string-append
+ (if (not close) "M " "L ")
+ (control->string c0)
+ "C " (apply string-append (map control->string c123))
+ (if (not close) "" (string-append
+ "L " (control->string close))))));; " Z")))))
+
+
+(define (sqr x)
+ (* x x))
+
+(define (fontify font expr)
+ (tagify "text" expr (cons 'style (svg-font font))))
+;; (cons 'unicode-range "U+EE00-EEFF"))))
+
+;;;;;;;;;;;;;;;;;;; share this utf8 stuff from output-gnome
+;;;;;;;;;;;;;;;;;;;
+(define (utf8 i)
+ (cond
+ ((< i #x80) (list (integer->char i)))
+ ((< i #x800) (map integer->char
+ (list (+ #xc0 (quotient i #x40))
+ (+ #x80 (modulo i #x40)))))
+ ((< i #x10000)
+ (let ((x (quotient i #x1000))
+ (y (modulo i #x1000)))
+ (map integer->char
+ (list (+ #xe0 x)
+ (+ #x80 (quotient y #x40))
+ (+ #x80 (modulo y #x40))))))
+ (else FIXME)))
+
+(define (custom-utf8 i)
+ (if (< i 80)
+ (utf8 i)
+ (utf8 (+ #xee00 i))))
+
+(define (string->utf8-string string)
+ (list->string
+ (apply append (map utf8 (map char->integer (string->list string))))))
+
+(define (char->utf8-string char)
+ (list->string (utf8 (char->integer char))))
+;; (list->string (custom-utf8 (char->integer char))))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; stencil outputters
+;;;
+
+;;; catch-all for missing stuff
+;;; comment this out to see find out what functions you miss :-)
+(define (dummy . foo) "")
+(map (lambda (x) (module-define! this-module x dummy))
+ (append
+ (ly:all-stencil-expressions)
+ (ly:all-output-backend-commands)))
+
+(define (beam width slope thick blot)
+ (let* ((x width)
+ (y (* slope width))
+ (z (sqrt (+ (sqr x) (sqr y)))))
+ (tagify "rect" ""
+ `(style . ,(format "fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-opacity:1;stroke-width:~f;stroke-linejoin:round;stroke-linecap:round;" line-thickness))
+ `(x . "0")
+ `(y . ,(number->string (* output-scale (- 0 (/ thick 2)))))
+ `(width . ,(number->string (* output-scale width)))
+ `(height . ,(number->string (* output-scale thick)))
+ ;;`(ry . ,(number->string (* output-scale half-lt)))
+ `(ry . ,(number->string (* output-scale (/ line-thickness 2))))
+ `(transform .
+ ,(format #f "matrix (~f, ~f, 0, 1, 0, 0) scale (~f, ~f)"
+ (/ x z)
+ (* -1 (/ y z))
+ 1 1)))))
+
+(define (bezier-sandwich l thick)
+ (let* (;;(l (eval urg-l this-module))
+ (first (list-tail l 4))
+ (first-c0 (car (list-tail first 3)))
+ (second (list-head l 4)))
+ (tagify "path" ""
+ `(stroke . "#000000")
+ `(stroke-width . ,(number->string line-thickness))
+ `(transform . ,(format #f "scale (~f, ~f)"
+ output-scale output-scale))
+ `(d . ,(string-append (svg-bezier first #f)
+ (svg-bezier second first-c0))))))
+
+(define (char font i)
+ (dispatch
+ `(fontify ,font ,(tagify "tspan" (char->utf8-string
+ (integer->char i))))))
+
+(define (comment s)
+ (string-append "<!-- " s " !-->\n"))
+
+(define (filledbox breapth width depth height)
+ (round-filled-box breapth width depth height line-thickness))
+
+(define (lily-def key val)
+ (cond
+ ((equal? key "lilypondpaperoutputscale")
+ ;; ugr
+ ;; If we just use transform scale (output-scale),
+ ;; all fonts come out scaled too (ie, much too big)
+ ;; So, we manually scale all other stuff.
+ (set! output-scale (* scale-to-unit (string->number val))))
+ ((equal? key "lilypondpaperlinethickness")
+ (set! line-thickness (* scale-to-unit (string->number val)))))
+ "")
+
+(define (placebox x y expr)
+ (tagify "g"
+ ;; FIXME -- JCN
+ ;;(dispatch expr)
+ expr
+ `(transform . ,(format #f "translate (~f, ~f)"
+ (* output-scale x)
+ (- 0 (* output-scale y))))))
+
+(define (round-filled-box breapth width depth height blot-diameter)
+ (tagify "rect" ""
+ `(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))
+ `(x . ,(number->string (* output-scale (- 0 breapth))))
+ `(y . ,(number->string (* output-scale (- 0 height))))
+ `(width . ,(number->string (* output-scale (+ breapth width))))
+ `(height . ,(number->string (* output-scale (+ depth height))))
+ ;;`(ry . ,(number->string (* output-scale half-lt)))
+ `(ry . ,(number->string (/ blot-diameter 2)))))
+
+(define (svg-font font)
+ (define (font-family)
+ (let ((name (ly:font-name font)))
+ (if name
+ (regexp-substitute/global #f "^GNU-(.*)-[.0-9]*$" name 'pre 1 'post)
+ (begin
+ (stderr "font-name: ~S\n" (ly:font-name font))
+ ;; TODO s/filename/file-name/
+ (stderr "font-filename: ~S\n" (ly:font-filename font))
+ (stderr "font-size: ~S\n" (font-size))
+ "ecrm12"))))
+
+ (define (font-size)
+ (let* ((designsize (ly:font-design-size font))
+ (magnification (* (ly:font-magnification font)))
+ (scaling (* magnification designsize)))
+ (debugf "scaling:~S\n" scaling)
+ (debugf "magnification:~S\n" magnification)
+ (debugf "design:~S\n" designsize)
+ scaling))
+
+ (format #f "font-family:~a;font-size:~a;fill:black;text-anchor:start;"
+ (font-family) (font-size)))
+
+(define (text font string)
+ (dispatch `(fontify ,font ,(tagify "tspan" (string->utf8-string string)))))
+
+;; WTF is this in every backend?
+(define (horizontal-line x1 x2 th)
+ (filledbox (- x1) (- x2 x1) (* .5 th) (* .5 th)))
projects / lilypond.git / commitdiff