X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-gnome.scm;h=ccb6d9d04b110025ee51136964aeba4cc26de72c;hb=9e69cb84d6ee5b0a861cd97869b10e3bdf0c833c;hp=a771a5cd8051c227662abab10847f281fd3df2ca;hpb=4511ab0f51688d176778af27b2f069e05809e5b0;p=lilypond.git diff --git a/scm/output-gnome.scm b/scm/output-gnome.scm index a771a5cd80..ccb6d9d04b 100644 --- a/scm/output-gnome.scm +++ b/scm/output-gnome.scm @@ -2,168 +2,84 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2004 Jan Nieuwenhuizen +;;;; (c) 2004--2006 Jan Nieuwenhuizen +;;;; TODO: +;;;; +;;;; * .cff MUST NOT be in fc's fontpath. +;;;; - workaround: remove mf/out from ~/.fonts.conf, +;;;; instead add ~/.fonts and symlink all /mf/out/*otf there. +;;;; - bug in fontconfig/freetype/pango? + +;;; * check: blot+scaling +;;; * Figure out and fix font scaling and character placement +;;; * EC font package: add missing X font directories and AFMs +;;; * User-interface, keybindings +;;; * Implement missing stencil functions +;;; * Implement missing commands +;;; * More information in stencils, e.g., location and grob tag. +;;; * Embedded Lily: +;;; - allow GnomeCanvas or `toplevel' GtkWindow to be created +;;; outside of LilyPond +;;; - lilylib. +;;; * Release schedule and packaging of dependencies. +;;; - g-wrap-1.9.3 is already in incoming. +;;; - guile-gnome-platform-2.8.0 will probably be packaged early 2005. -;;; HIP -- hack in progress -;;; ;;; You need: ;;; -;;; * guile-1.6.4 (NOT CVS) -;;; * Rotty's g-wrap--tng, possibly Janneke's if you have libffi-3.4. -;;; * lilypond branch: lilypond_2_3_2b; the framework-* backend -;;; loads output-gnome.scm at startup, which seems to break g-wrapped -;;; goops. -;;; -;;; see also: guile-gtk-general@gnu.org +;;; * Rotty's g-wrap >= 1.9.3 +;;; * guile-gnome-platform >= 2.7.97 +;;; * pango >= 1.6.0 ;;; +;;; See also: guile-gtk-general@gnu.org + ;;; Try it ;;; -;;; * Install g-wrap, guile-gnome (see script below) +;;; * Install gnome/gtk and libffi development stuff +;;; +;;; * Install [pango, g-wrap and] guile-gnome from source, +;;; see buildscripts/guile-gnome.sh ;;; -;;; * Use latin1 encoding for gnome backend, do -;;; make -C mf clean -;;; make -C mf ENCODING_FILE=$(kpsewhich cork.enc) -;;; (cd mf/out && mkfontdir) -;;; xset +fp $(pwd)/mf/out +;;; * Build LilyPond with gui support: configure --enable-gui ;;; -;;; * Setup PATHs: - +;;; * Supposing that LilyPond was built in ~/cvs/savannah/lilypond, +;;; tell fontconfig about the feta fonts dir and run fc-cache " -# do not use guile CVS: -export PATH=/usr/bin/:$PATH -# use g-wrap and guile-gnome from usr/pkg -export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$HOME/usr/pkg/g-wrap/share/guile/site/g-wrap:$HOME/usr/pkg/guile-gnome/share/guile -export LD_LIBRARY_PATH=$HOME/usr/pkg/g-wrap/lib:$HOME/usr/pkg/guile-gnome/lib +cat > ~/.fonts.conf << EOF + +~/cvs/savannah/lilypond/mf/out +/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: +" +fc-list | grep -i lily " - -;;; * Set XEDITOR and add -;;; #(ly:set-point-and-click 'line-column) -;;; to your .ly to get point-and-click -;;; -;;; * Run lily: lilypond-bin -fgnome input/simple-song.ly ;;; +;;; * Setup environment +" +export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$HOME/usr/pkg/g-wrap/share/guile/site/g-wrap:$HOME/usr/pkg/guile-gnome/share/guile:$GUILE_LOAD_PATH +export LD_LIBRARY_PATH=$HOME/usr/pkg/pango/lib:$HOME/usr/pkg/g-wrap/lib:$HOME/usr/pkg/guile-gnome/lib:$LD_LIBRARY_PATH +export XEDITOR='/usr/bin/emacsclient --no-wait +%l:%c %f' +" +;;; * Also for GNOME point-and-click, you need to set XEDITOR and add +" +#(ly:set-point-and-click 'line-column) +" +;;; to your .ly. ;;; -;;; todo: hmm --output-base broken? -;;; ### cd mf && mftrace --encoding=$(kpsewhich cork.enc) --autotrace --output-base=feta-cork-20 feta20.mf && mv feta20.pfa out - -;;; TODO: -;;; * pango+feta font (see archives gtk-i18n-list@gnome.org and -;;; lilypond-devel) -;;; - wait for/help with pango 1.6 -;;; - convert feta to OpenType (CFF) or TrueType (fontforge?) -;;; - hack feta20/feta20.pfa?: -;;; * font, canvas, scaling? -;;; * implement missing stencil functions -;;; * implement missing commands -;;; * user-interface, keybindings -;;; * cleanups: (too many) global vars - -;;; Note: this install information is volatile -;;; you'll probably want to pull all from -;;; from guile-gnome-devel@gnu.org--2004 soon -;;; - +;;; * Run lily: " -#!/bin/bash - -set -ex - -# no CVS guile. -export PATH=/usr/bin/:$PATH - -if [ -d $HOME/usr/pkg/libffi/ ] ; then - export LDFLAGS=-L$HOME/usr/pkg/libffi/lib/ - export CPPFLAGS=-I$HOME/usr/pkg/libffi/include -fi - -export AUTOMAKE=automake-1.8 -export AUTOCONF=autoconf2.50 - -rm -rf test -mkdir test -cd test - -## 1. install gnome-devel (Debian/unstable: apt-get install gnome-devel) - -## 2. *** NOTE: use guile-1.6 for g-wrap and guile-gnome *** -##### using GUILE CVS g-wrap/guile-gnome is experimental (read: segfaults) -PATH=/usr/bin:$PATH - - -## 3. get g-wrap 2.0 -tla register-archive a.rottmann@gmx.at--2004-main http://people.debian.org/~rotty/arch/a.rottmann@gmx.at/2004-main || true - -rm -rf g-wrap -## tla get a.rottmann@gmx.at--2004-main/g-wrap--tng g-wrap -## pull latest g-wrap from janneke -- this step is probably no longer -## necessary when you read this -tla register-archive janneke@gnu.org--2004-gnome http://lilypond.org/~janneke/{arch}/2004-gnome || true -tla get janneke@gnu.org--2004-gnome/g-wrap--janneke g-wrap -cd g-wrap - -rm -rf $HOME/usr/pkg/g-wrap -sh autogen.sh --noconfigure -mkdir =build -cd =build -../configure --prefix=$HOME/usr/pkg/g-wrap -make install - -# cp srfi-34.scm from CVS head ? --hwn -(cd $HOME/usr/pkg/g-wrap/share/guile/site - mv srfi-34.scm srfi-34.scm-g-wrap - cp $HOME/usr/pkg/guile/share/guile-1.7/srfi/srfi-34.scm .) - -cd ../.. - -## 4. get guile-gnome -tla register-archive guile-gnome-devel@gnu.org--2004 http://people.debian.org/~rotty/arch/guile-gnome-devel@gnu.org/2004/ || true -rm -rf guile-gnome -tla get guile-gnome-devel@gnu.org--2004/dists--dev guile-gnome -cd guile-gnome -tla build-config -r configs/gnu.org/dev -cd src - -## 5. get the gnome canvas module -tla get guile-gnome-devel@gnu.org--2004/libgnomecanvas--dev libgnomecanvas - -## pull latest defs from janneke -- this step is probably no longer -## necessary when you read this -## tla register-archive janneke@gnu.org--2004-gnome http://lilypond.org/~janneke/{arch}/2004-gnome || true -## rm -rf defs -## tla get janneke@gnu.org--2004-gnome/defs--janneke defs - -rm -rf $HOME/usr/pkg/guile-gnome -sh autogen.sh --noconfigure -mkdir ../=build -cd ../=build - -export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$GUILE_LOAD_PATH -export LD_LIBRARY_PATH=$HOME/usr/pkg/g-wrap/lib:$LD_LIBRARY_PATH -export PKG_CONFIG_PATH=$HOME/usr/pkg/g-wrap/lib/pkgconfig:$PKG_CONFIG_PATH - -../src/configure --prefix=$HOME/usr/pkg/guile-gnome - - -# requires 800mb RAM with -O2 -(cd libgnomecanvas/gnome/gw; perl -i~ -pe 's/-O2//g' Makefile) - -G_WRAP_MODULE_DIR=$HOME/usr/pkg/g-wrap/share/guile/site make install - -export GUILE_LOAD_PATH=$HOME/usr/pkg/guile-gnome/share/guile:$GUILE_LOAD_PATH -export LD_LIBRARY_PATH=$HOME/usr/pkg/guile-gnome/lib:$LD_LIBRARY_PATH -guile -s ../src/libgnomecanvas/examples/canvas.scm - - -# simple test -guile -s ../src/libgnomecanvas/examples/canvas.scm - +lilypond -fgnome input/simple-song.ly " - -(debug-enable 'backtrace) +;;; point-and-click: (mouse-1) click on a graphical object; +;;; grob-property-list: (mouse-3) click on a graphical object. (define-module (scm output-gnome)) - (define this-module (current-module)) (use-modules @@ -172,412 +88,252 @@ guile -s ../src/libgnomecanvas/examples/canvas.scm (srfi srfi-13) (lily) (gnome gtk) - (gnome gtk gdk-event) - ;; the name of the module will change to canvas rsn - ;;(gnome gw libgnomecanvas)) (gnome gw canvas)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; globals -;;; Lily output interface --- fix silly names and docme - -" - The output interface has functions for - * formatting stencils, and - * output commands - - Stencils: - beam - bezier-sandwich - bracket - ... - - Commands: - define-fonts - header - placebox - ... - - - The Bare minimum interface for \score { \notes c } } should - implement: - - INTERFACE-output-expression - char - filledbox - placebox - - and should intercept: -" - -(define (dummy . foo) #f) - -;; minimal intercept list: -(define output-interface-intercept - '(comment - define-fonts - end-output - header - header-end - lily-def - no-origin - output-scopes - start-page - stop-page - start-system - stop-system)) - -(map (lambda (x) (module-define! this-module x dummy)) - output-interface-intercept) - -(define-public (gnome-output-expression expr port) - (display (dispatch expr) port)) - -(define (dispatch expr) - (if (pair? 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")) - ""))))) - expr)) - -;;; Global vars -(define main-window #f) -(define main-scrolled #f) -(define main-canvas #f) +;;; set by framework-gnome.scm (define canvas-root #f) -(define page-number 0) - -(define page-stencils #f) -(define output-canvas #f) - -(define system-origin '(0 . 0)) - -;; UGHr -(define item-locations (make-hash-table 31)) -(define location #f) - -(define canvas-width 400) -(define canvas-height - (inexact->exact (round (* 1.42 canvas-width)))) - -(define font-paper #f) - -;;(define pixels-per-unit 1.0) -(define pixels-per-unit 2.0) - -;; TODO: use canvas scaling, use output-scale for paper/canvas dimensions? -;;(define output-scale (* 2 2.83464566929134)) -;;(define output-scale 2.83464566929134) -(define OUTPUT-SCALE 2.83464566929134) -(define output-scale (* OUTPUT-SCALE pixels-per-unit)) -;;(define output-scale 1) +(define output-scale #f) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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) (make-string 1 (integer->char i))) - ((< i #x800) (list->string - (map integer->char - (list (+ #xc0 (quotient i #x40)) - (+ #x80 (modulo i #x40)))))) + ((< 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))) - (list->string - (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 x-editor #f) -(define (get-x-editor) - (if (not x-editor) - (set! x-editor (getenv "XEDITOR"))) - x-editor) - -(define ifs #f) -(define (get-ifs) - (if (not ifs) - (set! ifs (getenv "IFS"))) - (if (not ifs) - (set! ifs " ")) - ifs) + (map integer->char + (list (+ #xe0 x) + (+ #x80 (quotient y #x40)) + (+ #x80 (modulo y #x40)))))) + (else (begin (stderr "programming-error: utf-8 too big:~x\n" i) + (list (integer->char 32)))))) + +(define (integer->utf-8-string integer) + (list->string (utf-8 integer))) + +(define (char->utf-8-string char) + (list->string (utf-8 (char->integer char)))) + +(define (string->utf-8-string string) + (apply + string-append + (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"))) + +;;; FONT may be font smob, or pango font string +(define (pango-font-name font) + (if (string? font) + (list font "Regular") + (apply format (append '(#f "~a, ~a") (font-name-style font))))) + +;;; FONT may be font smob, or pango font string +(define (canvas-font-size font) + ;; FIXME: 1.85? + (* 1.85 + (if (string? font) + 12 + (* output-scale (modified-font-metric-font-scaling font))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Wrappers from guile-gnome TLA +;;; guile-gnome-devel@gnu.org--2004 +;;; http://arch.gna.org/guile-gnome/archive-2004 +;;; +;;; janneke@gnu.org--2004-gnome +;;; http://lilypond.org/~janneke/{arch}/2004-gnome +;;; +(if (not (defined? ')) + (begin + (define-class () + (closure #:init-value (gnome-canvas-path-def-new) + #:init-keyword #:path-def + #:getter get-def #:setter set-def)) + + (define-method (moveto (this ) x y) + (gnome-canvas-path-def-moveto (get-def this) x y)) + (define-method (curveto (this ) x1 y1 x2 y2 x3 y3) + (gnome-canvas-path-def-curveto (get-def this) x1 y1 x2 y2 x3 y3)) + (define-method (lineto (this ) x y) + (gnome-canvas-path-def-lineto (get-def this) x y)) + (define-method (closepath (this )) + (gnome-canvas-path-def-closepath (get-def this))) + (define-method (reset (this )) + (gnome-canvas-path-def-reset (get-def this))) + + (define -set-path-def set-path-def) + (define -get-path-def get-path-def) + + (define-method (set-path-def (this ) + (def )) + (-set-path-def this (get-def def))) -(define (spawn-editor location) - (let* ((line (car location)) - (column (cadr location)) - (file-name (caddr location)) - (template (substring (get-x-editor) 0)) - - ;; Adhere to %l %c %f? - (command - (regexp-substitute/global - #f "%l" (regexp-substitute/global - #f "%c" - (regexp-substitute/global - #f "%f" template 'pre file-name 'post) - 'pre (number->string column) - 'post) - 'pre (number->string line) 'post))) + (define-method (get-path-def (this )) + (make #:path-def (-get-path-def this))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; stencil outputters +;;; + +;;; catch-all for missing stuff +;;; comment this out to see find out what functions you miss :-) +(define (dummy . foo) #f) +(map (lambda (x) (module-define! this-module x dummy)) + (append + (ly:all-stencil-expressions) + (ly:all-output-backend-commands))) + +;; two beziers +(define (bezier-sandwich lst thick) + (let* ((def (make )) + (bezier (make + #:parent (canvas-root) + #:fill-color "black" + #:outline-color "black" + #: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 - (stderr "spawning: ~s\n" command) - (if (= (primitive-fork) 0) - (let ((command-list (string-split command #\ )));; (get-ifs)))) - (apply execlp command-list) - (primitive-exit))))) - -(define location-callback spawn-editor) - -(define (item-event item event . data) - (case (gdk-event:type event) - ((enter-notify) (gobject-set-property item 'fill-color "white")) - ((leave-notify) (gobject-set-property item 'fill-color "black")) - ((button-press) - (let ((location (hashq-ref item-locations item #f))) - (if location - (location-callback location) - (stderr "no location\n")))) - ((2button-press) (gobject-set-property item 'fill-color "red"))) - #t) - -;; TODO: one list per-page -(define text-items '()) -(define (scale-canvas factor) - (set! pixels-per-unit (* pixels-per-unit factor)) - (set-pixels-per-unit main-canvas pixels-per-unit) + (moveto def (car (list-ref lst 3)) (- (cdr (list-ref lst 3)))) + (curveto def (car (list-ref lst 0)) (- (cdr (list-ref lst 0))) + (car (list-ref lst 1)) (- (cdr (list-ref lst 1))) + (car (list-ref lst 2)) (- (cdr (list-ref lst 2)))) + + (lineto def (car (list-ref lst 7)) (- (cdr (list-ref lst 7)))) + (curveto def (car (list-ref lst 4)) (- (cdr (list-ref lst 4))) + (car (list-ref lst 5)) (- (cdr (list-ref lst 5))) + (car (list-ref lst 6)) (- (cdr (list-ref lst 6)))) + (lineto def (car (list-ref lst 3)) (- (cdr (list-ref lst 3)))) + + (closepath def) + (set-path-def bezier def) + bezier)) + +(define (char font i) + (text font (ly:font-index-to-charcode font i))) + +(define (dashed-line thick on off dx dy) + (draw-line thick 0 0 dx dy)) + +(define (draw-line thick x1 y1 x2 y2) + (let* ((def (make )) + (props (make + #:parent (canvas-root) + #:fill-color "black" + #:outline-color "black" + #:width-units thick))) + (reset def) + (moveto def x1 (- y1)) + (lineto def x2 (- y2)) + (set-path-def props def) + props)) + + +;; 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 w-x-y-named-glyphs) (for-each (lambda (x) - (let ((scale (gobject-get-property x 'scale)) - (points (gobject-get-property x 'size-points))) - ;;(gobject-set-property x 'scale pixels-per-unit) - (gobject-set-property x 'size-points (* points factor)))) - text-items)) - -(define (key-press-event item event . data) - (let ((keyval (gdk-event-key:keyval event)) - (mods (gdk-event-key:modifiers event))) - (cond ((and (or (eq? keyval gdk:q) - (eq? keyval gdk:w)) - (equal? mods '(control-mask modifier-mask))) - (gtk-main-quit)) - ((and #t ;;(null? mods) - (eq? keyval gdk:plus)) - (scale-canvas 2)) - ((and #t ;; (null? mods) - (eq? keyval gdk:minus)) - (scale-canvas 0.5)) - ((or (eq? keyval gdk:Page-Up) - (eq? keyval gdk:BackSpace)) - (dump-page (1- page-number))) - ((or (eq? keyval gdk:Page-Down) - (eq? keyval gdk:space)) - (dump-page (1+ page-number)))) - #f)) -(define (char font i) - (text font (utf8 i))) + ;; 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 (cadr x) (caddr x) + (make + #:parent (canvas-root) + ;;#:x 0.0 #:y (if (music-font? font) 0.15 0.69) + #:x 0.0 #:y 0.0 + #:anchor 'west + #:font (pango-font-name font) + #:size-points (canvas-font-size font) + #:size-set #t + #:text + (integer->utf-8-string + (ly:font-glyph-name-to-charcode font (cadddr x)))))) + w-x-y-named-glyphs)) + +(define (grob-cause offset grob) + grob) + + +(define (named-glyph font name) + (text font (ly:font-glyph-name-to-charcode font name))) (define (placebox x y expr) - (stderr "item: ~S\n" expr) (let ((item expr)) ;;(if item ;; FIXME ugly hack to skip #unspecified ... (if (and item (not (eq? item (if #f #f)))) (begin - (move item - (* output-scale (+ (car system-origin) x)) - (* output-scale (- (car system-origin) y))) + (move item (* output-scale x) (* output-scale (- y))) (affine-relative item output-scale 0 0 output-scale 0 0) - - (gtype-instance-signal-connect item 'event item-event) - (if location - (hashq-set! item-locations item location)) item) #f))) -(define (round-filled-box breapth width depth height blot-diameter) - ;; FIXME: no rounded corners on rectangle - (make - #:parent canvas-root - #:x1 (- breapth) #:y1 depth #:x2 width #:y2 (- height) - #:fill-color "black" #:width-units blot-diameter)) - -;;(define (fontify font expr) -;; #f) - -(define (main outputter pages) - (let* ((window (make #:type 'toplevel)) - (button (make #:label "Exit")) - (next (make #:label "Next")) - (prev (make #:label "Previous")) - (canvas (make )) - (vbox (make #:homogeneous #f)) - (hbox (make #:homogeneous #f)) - (scrolled (make ))) - - (add window vbox) - (add vbox scrolled) - (add scrolled canvas) - - ;;(set-size-request button canvas-width 20) - ;;(add vbox button) - ;;(set-child-packing vbox button #f #f 0 'end) - - (add vbox hbox) - (set-size-request hbox canvas-width 25) - (set-child-packing vbox hbox #f #f 0 'end) +(define (polygon coords blot-diameter) + (let* ((def (make )) + (props (make + #:parent (canvas-root) + #:fill-color "black" + #:outline-color "black" + #:join-style 'round) + #:width-units blot-diameter) + (points (ly:list->offsets '() coords)) + (last-point (car (last-pair points)))) - (set-child-packing hbox button #f #f 0 'end) - ;;(set-size-request next 40 25) - ;;(set-size-request prev 40 25) - (set-size-request button (/ canvas-width 2) 25) - - (add hbox next) - (add hbox prev) - (add hbox button) - - - (gtype-instance-signal-connect button 'clicked - (lambda (b) (gtk-main-quit))) - (gtype-instance-signal-connect next 'clicked - (lambda (b) (dump-page (1+ page-number)))) - (gtype-instance-signal-connect prev 'clicked - (lambda (b) (dump-page (1- page-number)))) - - ;; papersize - (set-size-request canvas canvas-width canvas-height) - (set-scroll-region canvas 0 0 2000 4000) - (set-pixels-per-unit canvas pixels-per-unit) - - (gtype-instance-signal-connect window 'key-press-event key-press-event) - (show-all window) - - ;; HMMM - (set! canvas-root (root canvas)) - (set! main-canvas canvas) - (set! main-window window) - (set! output-canvas outputter) - (set! page-stencils pages) - (set! main-scrolled scrolled) - - (dump-page 0) - (gtk-main))) + (reset def) + (moveto def (car last-point) (cdr last-point)) + (for-each (lambda (x) (lineto def (car x) (cdr x))) points) + (closepath def) + (set-path-def props def) + props)) -(define (pango-font-name font) - (cond - ((equal? (ly:font-name font) "GNU-LilyPond-feta-20") - "lilypond-feta, regular 32") - (else - (ly:font-filename font)))) - -(define (pango-font-size font) - (let* ((designsize (ly:font-design-size font)) - (magnification (* (ly:font-magnification font))) - ;;(ops (ly:paper-lookup paper 'outputscale)) - ;;(ops (* pixels-per-unit OUTPUT-SCALE)) - ;;(ops (* pixels-per-unit pixels-per-unit)) - (ops (* (/ 12 20) (* pixels-per-unit pixels-per-unit))) - (scaling (* ops magnification designsize))) - scaling)) - -(define (text font string) - (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-name: ~S\n" (pango-font-name font)) - (stderr "pango-font-size: ~S\n" (pango-font-size font)) - (set! - text-items - (cons - (make - #:parent canvas-root - #:x 0 #:y 0 - ;; #:font "new century schoolbook, i bold 20" - #:font (pango-font-name font) - ;; #:size-points 12 - #:size-points (pango-font-size font) - ;;#:size (pango-font-size font) - #:size-set #t - - ;;apparently no effect :-( - ;;#:scale 1.0 - ;;#:scale-set #t - +(define (round-filled-box breapth width depth height blot-diameter) + (let ((r (/ blot-diameter 2))) + (make + #:parent (canvas-root) + #:x1 (- r breapth) #:y1 (- depth r) #:x2 (- width r) #:y2 (- r height) #:fill-color "black" - #:text string - #:anchor 'west) - text-items)) - (car text-items)) - -(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) - ;;(let ((thickness 2)) - (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness))) - -(define (start-system origin . rest) - (set! system-origin origin)) - -;; origin -- bad name -(define (define-origin file line col) - ;; ughr, why is this not passed as [part of] stencil object - (set! location (if (procedure? point-and-click) - ;; duh, only silly string append - ;; (point-and-click line col file) - (list line col file) - #f))) - -(define (dump-page number) - (if (or (not page-stencils) - (< number 0) - (>= number (vector-length page-stencils))) - (stderr "No such page: ~S\n" (1+ number)) - (begin - (set! page-number number) - - ;; no destroy method for gnome-canvas-text? - ;;(map destroy (gtk-container-get-children main-canvas)) - ;;(map destroy text-items) - - ;; UGHR - destroying the whole canvas.... - (if (and main-canvas - (not (null? text-items))) - (let* ((canvas (make )) - (root (root canvas))) - - (destroy main-canvas) - (add main-scrolled canvas) - - ;; papersize - (set-size-request canvas canvas-width canvas-height) - (set-scroll-region canvas 0 0 2000 4000) - (set-pixels-per-unit canvas pixels-per-unit) - (show canvas) - - (set! main-canvas canvas) - (set! canvas-root root) - (set! text-items '()))) - - (ly:outputter-dump-stencil output-canvas - (vector-ref page-stencils page-number))))) - + #:outline-color "black" + #:width-units blot-diameter + #:join-style 'round))) + +(define (text font s) + (make + #:parent (canvas-root) + ;;#: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->utf-8-string s) + (string->utf-8-string s)))) + +(define (utf-8-string pango-font-description string) + (make + #:parent (canvas-root) + #:x 0.0 #:y 0.0 + #:anchor 'west + #:font pango-font-description + #:size-points (canvas-font-size pango-font-description) + #:size-set #t + #:text string))