X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-sodipodi.scm;h=6f6ee224b1c012b5bb90a4c4c77c1b73d985cf99;hb=1c79c7c8cf6835aeff33280d93cec344182c2cba;hp=0d7046c0bd64a58f4d7ec2545931e77dca7b0a1a;hpb=f7668e993b09e736286258276667e86e16dab557;p=lilypond.git diff --git a/scm/output-sodipodi.scm b/scm/output-sodipodi.scm index 0d7046c0bd..6f6ee224b1 100644 --- a/scm/output-sodipodi.scm +++ b/scm/output-sodipodi.scm @@ -2,7 +2,7 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2002--2003 Jan Nieuwenhuizen +;;;; (c) 2002--2004 Jan Nieuwenhuizen ;;;; NOTE: ;;;; @@ -39,13 +39,11 @@ ;;; and should intercept: ;;; -;;; fontify ;;; lily-def ;;; header-end ;;; define-fonts ;;; no-origin ;;; start-system -;;; end-output ;;; header ;;; comment ;;; stop-last-system @@ -62,7 +60,6 @@ (cond ((eq? keyword 'some-func) "") ;;((eq? keyword 'placebox) (dispatch (cadddr expr))) - ;;((eq? keyword 'fontify) (dispatch (caddr expr))) (else (if (module-defined? this-module keyword) (apply (eval keyword this-module) (cdr expr)) @@ -74,7 +71,12 @@ ;; Global vars -(define output-scale 1) +;;; 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) @@ -88,12 +90,7 @@ ((equal? (ly:unit) "pt") (/ 72.0 72.27)) (else (error "unknown unit" (ly:unit))))) -;; alist containing fontname -> fontcommand assoc (both strings) -;;(define font-name-alist '()) - ;; Helper functions - - (define (tagify tag string . attribute-alist) (string-append "<" tag @@ -130,12 +127,12 @@ (define (control-flip-y c) (cons (car c) (* -1 (cdr c)))) -(define (numbers->string l) +(define (ly:numbers->string l) (string-append (number->string (car l)) (if (null? (cdr l)) "" - (string-append "," (numbers->string (cdr l)))))) + (string-append "," (ly:numbers->string (cdr l)))))) (define (svg-bezier l close) (let* ((c0 (car (list-tail l 3))) @@ -172,7 +169,7 @@ sodipodi:docname='/tmp/x'> - ") @@ -221,29 +218,6 @@ (* -1 (/ y z)) 1 1))))) -;; TODO: bezier-ending, see ps.scm -(define (bezier-bow urg-l thick) - - (define (bezier-ending z0 z1 z2) - (let ((x0 (car z0)) - (y0 (cdr z0)) - (x1 (car z1)) - (y1 (cdr z1)) - (x2 (car z2)) - (y2 (cdr z2))) - (let ((r (/ (sqrt (+ (* (- x1 x2) (- x1 x2)) - (* (- y1 y2) (- y1 y2)))) 2))) - (tagify "circle" "" - `(fill . "#000000;") - `(cx . ,(number->string (* output-scale x0))) - `(cy . ,(number->string (* output-scale (- 0 y0)))) - `(r . ,(number->string (* output-scale r))))))) - - (let ((l (eval urg-l this-module))) - (string-append - (bezier-sandwich l thick) - (bezier-ending (list-ref l 3) (list-ref l 0) (list-ref l 5)) - (bezier-ending (list-ref l 7) (list-ref l 0) (list-ref l 5))))) (define (bezier-sandwich l thick) (let* (;;(l (eval urg-l this-module)) @@ -258,30 +232,22 @@ `(d . ,(string-append (svg-bezier first #f) (svg-bezier second first-c0)))))) -(define (char i) - (if #t - ;;(tagify "tspan" (format #f "à~2,'0x;" i)) - (tagify "tspan" (ascii->upm-string i)) - (begin - (format #t "can't display char: ~x\n" i) - " "))) +(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 internal-external-name-mag-pairs) - (comment (format #f "Fonts used: ~S" internal-external-name-mag-pairs))) - -(define (end-output) - "") - -;;TODO -;(define (horizontal-line x1 x2 th) -; (draw-line th x1 0 x2 0)) +(define (define-fonts layout font-list) + (comment (format #f "Fonts used: ~S" font-list))) (define (filledbox breapth width depth height) - (roundfilledbox breapth width depth height line-thickness)) + (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;") @@ -292,6 +258,9 @@ ("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;")) @@ -305,29 +274,36 @@ font-cruft "font-family:LilyPond-Parmesan;font-style:-Parmesan;font-size:20;")))) -(define (get-font name-mag-pair) - ;; name-mag-pair: (quote ("feta20" . 0.569055118110236))"feta20"(quote ("feta20" . 0.569055118110236)) - (let ((f (assoc (caadr name-mag-pair) font-alist))) - (if (pair? f) - (cdr f) - (begin - (format #t "font not found: ~s\n" (caadr name-mag-pair)) - (cdr (assoc "feta20" font-alist)))))) - -(define (fontify name-mag-pair expr) - (string-append - (tagify "text" (dispatch expr) (cons 'style (get-font name-mag-pair))))) +(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 generate) +(define (header creator time-stamp layout page-count- classic?) (string-append xml-header (comment creator) - (comment generate) + (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 @@ -346,7 +322,10 @@ (define (placebox x y expr) - (tagify "g" (dispatch expr) + (tagify "g" + ;; FIXME -- JCN + ;;(dispatch expr) + expr `(transform . ,(string-append "translate(" @@ -356,7 +335,7 @@ (number->string (- 0 (* output-scale y))) ")")))) -(define (roundfilledbox breapth width depth height blot-diameter) +(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)) @@ -370,29 +349,47 @@ ;; TODO: use height, set scaling? -(define (start-system width height) +(define (start-system origin dim) +;;(define (start-system width height) (let ((y system-y)) - ;;" - (set! system-y (+ system-y height)) - ;;(format #f "" y))) + (set! system-y (+ system-y (cdr dim))) (string-append "\n" (comment "start-system") (format #f "\n" (* output-scale y))))) -(define (stop-system) +(define (stop-system last?) (string-append "\n" (comment "stop-system") "\n")) -(define stop-last-system stop-system) - -(define (text s) +(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? - (if #t - (tagify "tspan" s) - (tagify "tspan" - (apply string-appendb - (map (lambda (x) (ascii->upm-string (char->integer x))) - (string->list s)))))) + (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))) +