1 ;;;; output-gnome.scm -- implement GNOME canvas output
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2004 Jan Nieuwenhuizen <janneke@gnu.org>
8 ;;; HIP -- hack in progress
10 ;;; Note: this install information is volatile
11 ;;; you'll probably want to pull all from
12 ;;; from guile-gnome-devel@gnu.org--2004 soon
14 ;;; move this into workbook?
17 ## install gnome-devel
19 ## use guile-1.6 for g-wrap/guile-gnome
23 tla register-archive a.rottmann@gmx.at--2004-main http://people.debian.org/~rotty/arch/a.rottmann@gmx.at/2004-main || true
26 tla get a.rottmann@gmx.at--2004-main/g-wrap--tng gw-pristine
29 AUTOMAKE=automake-1.8 AUTOCONF=autoconf2.50 sh autogen.sh --noconfigure
32 ../configure --prefix=$HOME/usr/pkg/g-wrap
38 tla register-archive guile-gnome-devel@gnu.org--2004 http://people.debian.org/~rotty/arch/guile-gnome-devel@gnu.org/2004/ || true
40 tla guile-gnome-devel@gnu.org--2004/dists--dev guile-gnome
42 tla build-config -r configs/gnu.org/dev
44 ## ugh: get janneke's stuff -- should make build-config, I guess?
45 tla register-archive janneke@gnu.org--2004-gnome http://lilypond.org/~janneke/{arch}/2004-gnome || true
48 tla get janneke@gnu.org--2004-gnome/libgnomecanvas--janneke--0 libgnomecanvas
49 tla get janneke@gnu.org--2004-gnome/libgnomecanvas--janneke--0 defs
51 AUTOMAKE=automake-1.8 AUTOCONF=autoconf2.50 sh autogen.sh --noconfigure
55 export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$GUILE_LOAD_PATH
56 export LD_LIBRARY_PATH=$HOME/usr/pkg/g-wrap/lib:$LD_LIBRARY_PATH
57 export PKG_CONFIG_PATH=$HOME/usr/pkg/g-wrap/lib/pkgconfig:$PKG_CONFIG_PATH
59 ../src/configure --prefix=$HOME/usr/pkg/guile-gnome
61 G_WRAP_MODULE_DIR=$HOME/usr/pkg/g-wrap/share/guile/site make install
63 (cd $HOME/usr/pkg/guile-gnome/share/guile/gnome && mv gtk/g[dt]k.scm gw)
65 export GUILE_LOAD_PATH=$HOME/usr/pkg/guile-gnome/share/guile:$GUILE_LOAD_PATH
66 export LD_LIBRARY_PATH=$HOME/usr/pkg/guile-gnome/lib:$LD_LIBRARY_PATH
67 guile -s ../src/gtk/examples/hello.scm
70 lilypond-bin -fgnome input/simple-song.ly
77 (debug-enable 'backtrace)
79 (define-module (scm output-gnome))
80 (define this-module (current-module))
86 (gnome gw libgnomecanvas))
89 ;;; Lily output interface --- fix silly names and docme
92 The output interface has functions for
93 * formatting stencils, and
109 The Bare minimum interface for \score { \notes c } } should
112 INTERFACE-output-expression
117 and should intercept:
120 (define (dummy . foo) #f)
122 ;; minimal intercept list:
123 (define output-interface-intercept
139 (map (lambda (x) (module-define! this-module x dummy))
140 output-interface-intercept)
142 (define-public (gnome-output-expression expr port)
143 (display (dispatch expr) port))
145 (define (dispatch expr)
146 (let ((keyword (car expr)))
148 ((eq? keyword 'some-func) "")
149 ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
151 (if (module-defined? this-module keyword)
152 (apply (eval keyword this-module) (cdr expr))
155 (string-append "undefined: " (symbol->string keyword) "\n"))
160 (define main-window #f)
161 (define canvas-root #f)
163 (define output-scale (* 2 2.83464566929134))
165 (define line-thickness 0.001)
168 (define (char font i)
169 (let ((item (make <gnome-canvas-text> #:x 0 #:y 0
170 #:font "new century schoolbook, i bold 20"
171 #:text (char->string i))))
172 (add canvas-root txt)))
174 (define (placebox x y expr)
177 ;; gnome_canvas_item_new (gnome_canvas_root (canvas),
178 ;; gnome_canvas_rect_get_type (),
179 ;; "x1", (double) x1,
180 ;; "y1", (double) y1,
181 ;; "x2", (double) x2,
182 ;; "y2", (double) y2,
183 ;; "fill_color", "black",
184 ;; "outline_color", "black",
185 ;; "width_units", 1.0,
188 (define (round-filled-box breapth width depth height blot-diameter)
189 (let* ((x1 . ,(number->string (* output-scale (- 0 breapth))))
190 (y1 . ,(number->string (* output-scale (- 0 height))))
191 (x2 . ,(number->string (* output-scale width)))
192 (y2 . ,(number->string (* output-scale height)))
193 ;;(ry . ,(number->string (/ blot-diameter 2)))
194 ;; FIXME: no rounded corners on rectangle
195 (item (make <gnome-canvas-rect>
196 #:x1 x1 #:y1 y1 #:x2 x2.0 #:y2 y2
197 ;;#:width-unit blot-diameter
199 (add canvas-root item)))
201 (define (fontify font expr)
207 (define (header . rest)
208 (let* ((window (make <gtk-window> #:type 'toplevel))
209 (button (make <gtk-button> #:label "Exit"))
210 (canvas (make <gnome-canvas> ))
211 (vbox (make <gtk-vbox>)))
213 (gtk-container-add window vbox)
214 (gtk-widget-show vbox)
216 (set-size-request canvas 300 300)
217 (gtk-container-add vbox canvas)
219 (gtk-container-add vbox button)
220 (gtype-instance-signal-connect button 'clicked
221 (lambda (b) (gtk-main-quit)))
223 (gtk-widget-show canvas)
224 (gtk-widget-show button)
225 (gtk-widget-show window)
227 (set! canvas-root (root canvas))
228 (set! main-window window)))
230 (define (text font string)
231 (let ((item (make <gnome-canvas-text> #:x 0 #:y 0
232 #:font "new century schoolbook, i bold 20"
234 (add canvas-root txt)))
236 (define (filledbox a b c d)
237 (round-filled-box a b c d 0.001))
239 ;; WTF is this in every backend?
240 (define (horizontal-line x1 x2 th)
241 (filledbox (- x1) (- x2 x1) (* .5 th) (* .5 th)))