From 1a30621b7f53bab51449dac495bb0ec90cd0aab2 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 16 Nov 2004 00:19:06 +0000 Subject: [PATCH] * 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. --- ChangeLog | 16 ++ lily/main.cc | 7 +- scm/framework-gnome.scm | 1 + scm/framework-svg.scm | 75 ++++++++ scm/lily-library.scm | 12 ++ scm/lily.scm | 4 +- scm/output-gnome.scm | 206 ++++++++++++--------- scm/output-ps.scm | 7 - scm/output-sodipodi.scm | 395 ---------------------------------------- scm/output-svg.scm | 243 ++++++++++++++++++++++++ 10 files changed, 473 insertions(+), 493 deletions(-) create mode 100644 scm/framework-svg.scm delete mode 100644 scm/output-sodipodi.scm create mode 100644 scm/output-svg.scm diff --git a/ChangeLog b/ChangeLog index 4fd80c14ce..154227db5c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,19 @@ +2004-11-16 Jan Nieuwenhuizen + + * 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 + + * scm/output-gnome.scm (beam): New function. + (slur): Round corners. + (round-filled-box): Round corners. + 2004-11-16 Han-Wen Nienhuys * scm/output-gnome.scm (beam): add function. diff --git a/lily/main.cc b/lily/main.cc index a80e00e0df..0c91f2cfd8 100644 --- a/lily/main.cc +++ b/lily/main.cc @@ -256,12 +256,14 @@ static void 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) @@ -277,6 +279,7 @@ determine_output_options () make_tex = true; } if (!found_gnome + && !found_svg && !(make_dvi || make_tex || make_ps @@ -293,7 +296,7 @@ determine_output_options () } } -void init_global_tweak_registry(); +void init_global_tweak_registry (); static void main_with_guile (void *, int, char **) diff --git a/scm/framework-gnome.scm b/scm/framework-gnome.scm index b142836ccc..f49bca32f1 100644 --- a/scm/framework-gnome.scm +++ b/scm/framework-gnome.scm @@ -85,6 +85,7 @@ (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) diff --git a/scm/framework-svg.scm b/scm/framework-svg.scm new file mode 100644 index 0000000000..7415536ec6 --- /dev/null +++ b/scm/framework-svg.scm @@ -0,0 +1,75 @@ +;;;; framework-svg.scm -- +;;;; +;;;; source file of the GNU LilyPond music typesetter +;;;; +;;;; (c) 2004 Jan Nieuwenhuizen + +(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 "\n" + page-width page-height)) + (ly:outputter-dump-string + outputter "\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\n\n"))) + +(define (comment s) + (string-append "\n")) + +;; FIXME: gulp from file +(define xml-header + " + +") + +(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 "\n" (* output-scale y)))) + "\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)) + "\n"))) diff --git a/scm/lily-library.scm b/scm/lily-library.scm index 9cc606a329..3d3e19c148 100644 --- a/scm/lily-library.scm +++ b/scm/lily-library.scm @@ -1,3 +1,9 @@ +;;;; lily-library.scm -- utilities +;;;; +;;;; source file of the GNU LilyPond music typesetter +;;;; +;;;; (c) 1998--2004 Jan Nieuwenhuizen +;;;; Han-Wen Nienhuys (define-public X 0) @@ -312,3 +318,9 @@ possibly turned off." (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))))) + diff --git a/scm/lily.scm b/scm/lily.scm index b3d4b01271..fd0ae671cd 100644 --- a/scm/lily.scm +++ b/scm/lily.scm @@ -1,12 +1,10 @@ -;;;; 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 ;;;; Han-Wen Nienhuys -;;; Library functions - (if (defined? 'set-debug-cell-accesses!) (set-debug-cell-accesses! #f)) diff --git a/scm/output-gnome.scm b/scm/output-gnome.scm index df32812065..a993d99a0b 100644 --- a/scm/output-gnome.scm +++ b/scm/output-gnome.scm @@ -39,7 +39,7 @@ ;;; * 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 @@ -47,6 +47,7 @@ cat > ~/.fonts.conf << EOF /usr/share/texmf/fonts/type1/public/ec-fonts-mftraced 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: @@ -177,12 +178,6 @@ lilypond -fgnome input/simple-song.ly (define (char->utf8-string char) (list->string (utf8 (char->integer char)))) -(define (draw-rectangle x1 y1 x2 y2 color width-units) - (make - #:parent (canvas-root) #:x1 x1 #:y1 y1 #:x2 x2 #:y2 y2 - #:fill-color color #:width-units width-units)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; stencil outputters ;;; @@ -195,6 +190,56 @@ lilypond -fgnome input/simple-song.ly (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 )) + (bezier (make + #: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 )) + (y (* (- width) slope)) + (props (make + #: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 )) @@ -202,10 +247,12 @@ lilypond -fgnome input/simple-song.ly #: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 @@ -227,6 +274,21 @@ lilypond -fgnome input/simple-song.ly (define (char font i) (text font (utf8 i))) +;; FIXME: naming +(define (filledbox breapth width depth height) + (make + #: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)) @@ -241,27 +303,6 @@ lilypond -fgnome input/simple-song.ly item) #f))) -(define (beam width slope thick blot) - (let* - ((def (make )) - (y (* (- width) slope)) - (props (make - #: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)) @@ -310,51 +351,57 @@ lilypond -fgnome input/simple-song.ly (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 + #: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 #:parent (canvas-root) @@ -376,16 +423,3 @@ lilypond -fgnome input/simple-song.ly (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) diff --git a/scm/output-ps.scm b/scm/output-ps.scm index ae0d93e306..d9788b292c 100644 --- a/scm/output-ps.scm +++ b/scm/output-ps.scm @@ -209,13 +209,6 @@ (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* diff --git a/scm/output-sodipodi.scm b/scm/output-sodipodi.scm deleted file mode 100644 index 6f6ee224b1..0000000000 --- a/scm/output-sodipodi.scm +++ /dev/null @@ -1,395 +0,0 @@ -;;;; sodipodi.scm -- implement Scheme output routines for PostScript -;;;; -;;;; source file of the GNU LilyPond music typesetter -;;;; -;;;; (c) 2002--2004 Jan Nieuwenhuizen - -;;;; 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\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 -" - -]> -" -;;" -) - -(define svg-header -" - - - - ") - - - -;; 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 "\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 "\n" (* output-scale y))))) - -(define (stop-system last?) - (string-append - "\n" - (comment "stop-system") - "\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))) - diff --git a/scm/output-svg.scm b/scm/output-svg.scm new file mode 100644 index 0000000000..ef50cfc160 --- /dev/null +++ b/scm/output-svg.scm @@ -0,0 +1,243 @@ +;;;; output-svg.scm -- implement Scheme output routines for SVG1 +;;;; +;;;; source file of the GNU LilyPond music typesetter +;;;; +;;;; (c) 2002--2004 Jan Nieuwenhuizen + +;;;; 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 "\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 "\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))) -- 2.39.2