X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-gnome.scm;h=ccb6d9d04b110025ee51136964aeba4cc26de72c;hb=5693fcf8ea6357d19f3f4960c81e443104424ab6;hp=83ce839bae5ee07f72aa99a8d9c1a6b52b272281;hpb=c8a2b2102813a6556090a228771eaecef6f0b19c;p=lilypond.git diff --git a/scm/output-gnome.scm b/scm/output-gnome.scm index 83ce839bae..ccb6d9d04b 100644 --- a/scm/output-gnome.scm +++ b/scm/output-gnome.scm @@ -2,7 +2,7 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2004--2005 Jan Nieuwenhuizen +;;;; (c) 2004--2006 Jan Nieuwenhuizen ;;;; TODO: ;;;; @@ -79,8 +79,6 @@ lilypond -fgnome input/simple-song.ly ;;; point-and-click: (mouse-1) click on a graphical object; ;;; grob-property-list: (mouse-3) click on a graphical object. -(debug-enable 'backtrace) - (define-module (scm output-gnome)) (define this-module (current-module)) @@ -102,12 +100,7 @@ lilypond -fgnome input/simple-song.ly ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; helper functions -(define (stderr string . rest) - (apply format (cons (current-error-port) (cons string rest))) - (force-output (current-error-port))) - - -(define (utf8 i) +(define (utf-8 i) (cond ((< i #x80) (list (integer->char i))) ((< i #x800) (map integer->char @@ -120,24 +113,24 @@ lilypond -fgnome input/simple-song.ly (list (+ #xe0 x) (+ #x80 (quotient y #x40)) (+ #x80 (modulo y #x40)))))) - (else (begin (stderr "programming-error: utf8 too big:~x\n" i) + (else (begin (stderr "programming-error: utf-8 too big:~x\n" i) (list (integer->char 32)))))) -(define (integer->utf8-string integer) - (list->string (utf8 integer))) +(define (integer->utf-8-string integer) + (list->string (utf-8 integer))) -(define (char->utf8-string char) - (list->string (utf8 (char->integer char)))) +(define (char->utf-8-string char) + (list->string (utf-8 (char->integer char)))) -(define (string->utf8-string string) +(define (string->utf-8-string string) (apply string-append - (map (lambda (x) (char->utf8-string x)) (string->list string)))) + (map (lambda (x) (char->utf-8-string x)) (string->list string)))) (define (music-font? font) (let ((family (car (font-name-style font)))) (string=? (substring family 0 (min (string-length family) 10)) - "emmentaler"))) + "Emmentaler"))) ;;; FONT may be font smob, or pango font string (define (pango-font-name font) @@ -151,7 +144,7 @@ lilypond -fgnome input/simple-song.ly (* 1.85 (if (string? font) 12 - (* output-scale (font-size font))))) + (* output-scale (modified-font-metric-font-scaling font))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Wrappers from guile-gnome TLA @@ -201,54 +194,6 @@ 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 )) @@ -299,25 +244,18 @@ lilypond -fgnome input/simple-song.ly (set-path-def props def) props)) -;; 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)) ;; FIXME: the framework-gnome backend needs to see every item that ;; gets created. All items created here must should be put in a group ;; that gets returned. -(define (glyph-string font postscript-font-name x-y-named-glyphs) +(define (glyph-string font postscript-font-name w-x-y-named-glyphs) (for-each (lambda (x) ;; UGR, glyph names not found (stderr "GLYPH:~S\n" (caddr x)) (stderr "ID:~S\n" (ly:font-glyph-name-to-charcode font (caddr x))) - (placebox (car x) (cadr x) + (placebox (cadr x) (caddr x) (make #:parent (canvas-root) ;;#:x 0.0 #:y (if (music-font? font) 0.15 0.69) @@ -327,16 +265,13 @@ lilypond -fgnome input/simple-song.ly #:size-points (canvas-font-size font) #:size-set #t #:text - (integer->utf8-string - (ly:font-glyph-name-to-charcode font (caddr x)))))) - x-y-named-glyphs)) + (integer->utf-8-string + (ly:font-glyph-name-to-charcode font (cadddr x)))))) + w-x-y-named-glyphs)) (define (grob-cause offset grob) grob) -;; WTF is this in every backend? -(define (horizontal-line x1 x2 thickness) - (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness))) (define (named-glyph font name) (text font (ly:font-glyph-name-to-charcode font name))) @@ -383,16 +318,17 @@ lilypond -fgnome input/simple-song.ly (define (text font s) (make #:parent (canvas-root) - #:x 0.0 #:y 0.0 + ;;#:x 0.0 #:y 0.0 + #:x 0.0 #:y (if (music-font? font) 0.15 0.69) #:anchor (if (music-font? font) 'west 'south-west) #:font (pango-font-name font) #:size-points (canvas-font-size font) #:size-set #t #:text (if (integer? s) - (integer->utf8-string s) - (string->utf8-string s)))) + (integer->utf-8-string s) + (string->utf-8-string s)))) -(define (utf8-string pango-font-description string) +(define (utf-8-string pango-font-description string) (make #:parent (canvas-root) #:x 0.0 #:y 0.0