1 ;;;; output-gnome.scm -- implement GNOME canvas output
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2004--2005 Jan Nieuwenhuizen <janneke@gnu.org>
9 ;;;; * .cff MUST NOT be in fc's fontpath.
10 ;;;; - workaround: remove mf/out from ~/.fonts.conf,
11 ;;;; instead add ~/.fonts and symlink all /mf/out/*otf there.
12 ;;;; - bug in fontconfig/freetype/pango?
14 ;;; * check: blot+scaling
15 ;;; * Figure out and fix font scaling and character placement
16 ;;; * EC font package: add missing X font directories and AFMs
17 ;;; * User-interface, keybindings
18 ;;; * Implement missing stencil functions
19 ;;; * Implement missing commands
20 ;;; * More information in stencils, e.g., location and grob tag.
22 ;;; - allow GnomeCanvas or `toplevel' GtkWindow to be created
23 ;;; outside of LilyPond
25 ;;; * Release schedule and packaging of dependencies.
26 ;;; - g-wrap-1.9.3 is already in incoming.
27 ;;; - guile-gnome-platform-2.8.0 will probably be packaged early 2005.
31 ;;; * Rotty's g-wrap >= 1.9.3
32 ;;; * guile-gnome-platform >= 2.7.97
35 ;;; See also: guile-gtk-general@gnu.org
39 ;;; * Install gnome/gtk and libffi development stuff
41 ;;; * Install [pango, g-wrap and] guile-gnome from source,
42 ;;; see buildscripts/guile-gnome.sh
44 ;;; * Build LilyPond with gui support: configure --enable-gui
46 ;;; * Supposing that LilyPond was built in ~/cvs/savannah/lilypond,
47 ;;; tell fontconfig about the feta fonts dir and run fc-cache
49 cat > ~/.fonts.conf << EOF
51 <dir>~/cvs/savannah/lilypond/mf/out</dir>
52 <dir>/usr/share/texmf/fonts/type1/public/ec-fonts-mftraced</dir>
57 ;;; or copy all your .pfa/.pfb's to ~/.fonts if your fontconfig
58 ;;; already looks there for fonts. Check if it works by doing:
60 fc-list | grep -i lily
63 ;;; * Setup environment
65 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
66 export LD_LIBRARY_PATH=$HOME/usr/pkg/pango/lib:$HOME/usr/pkg/g-wrap/lib:$HOME/usr/pkg/guile-gnome/lib:$LD_LIBRARY_PATH
67 export XEDITOR='/usr/bin/emacsclient --no-wait +%l:%c %f'
69 ;;; * Also for GNOME point-and-click, you need to set XEDITOR and add
71 #(ly:set-point-and-click 'line-column)
77 lilypond -fgnome input/simple-song.ly
79 ;;; point-and-click: (mouse-1) click on a graphical object;
80 ;;; grob-property-list: (mouse-3) click on a graphical object.
82 (debug-enable 'backtrace)
84 (define-module (scm output-gnome))
85 (define this-module (current-module))
95 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
98 ;;; set by framework-gnome.scm
99 (define canvas-root #f)
100 (define output-scale #f)
102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
107 ((< i #x80) (list (integer->char i)))
108 ((< i #x800) (map integer->char
109 (list (+ #xc0 (quotient i #x40))
110 (+ #x80 (modulo i #x40)))))
112 (let ((x (quotient i #x1000))
113 (y (modulo i #x1000)))
116 (+ #x80 (quotient y #x40))
117 (+ #x80 (modulo y #x40))))))
118 (else (begin (stderr "programming-error: utf8 too big:~x\n" i)
119 (list (integer->char 32))))))
121 (define (integer->utf8-string integer)
122 (list->string (utf8 integer)))
124 (define (char->utf8-string char)
125 (list->string (utf8 (char->integer char))))
127 (define (string->utf8-string string)
130 (map (lambda (x) (char->utf8-string x)) (string->list string))))
132 (define (music-font? font)
133 (let ((family (car (font-name-style font))))
134 (string=? (substring family 0 (min (string-length family) 10))
137 ;;; FONT may be font smob, or pango font string
138 (define (pango-font-name font)
140 (list font "Regular")
141 (apply format (append '(#f "~a, ~a") (font-name-style font)))))
143 ;;; FONT may be font smob, or pango font string
144 (define (canvas-font-size font)
149 (* output-scale (modified-font-metric-font-scaling font)))))
151 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
152 ;;; Wrappers from guile-gnome TLA
153 ;;; guile-gnome-devel@gnu.org--2004
154 ;;; http://arch.gna.org/guile-gnome/archive-2004
156 ;;; janneke@gnu.org--2004-gnome
157 ;;; http://lilypond.org/~janneke/{arch}/2004-gnome
159 (if (not (defined? '<gnome-canvas-path-def>))
161 (define-class <gnome-canvas-path-def> (<gobject>)
162 (closure #:init-value (gnome-canvas-path-def-new)
163 #:init-keyword #:path-def
164 #:getter get-def #:setter set-def))
166 (define-method (moveto (this <gnome-canvas-path-def>) x y)
167 (gnome-canvas-path-def-moveto (get-def this) x y))
168 (define-method (curveto (this <gnome-canvas-path-def>) x1 y1 x2 y2 x3 y3)
169 (gnome-canvas-path-def-curveto (get-def this) x1 y1 x2 y2 x3 y3))
170 (define-method (lineto (this <gnome-canvas-path-def>) x y)
171 (gnome-canvas-path-def-lineto (get-def this) x y))
172 (define-method (closepath (this <gnome-canvas-path-def>))
173 (gnome-canvas-path-def-closepath (get-def this)))
174 (define-method (reset (this <gnome-canvas-path-def>))
175 (gnome-canvas-path-def-reset (get-def this)))
177 (define -set-path-def set-path-def)
178 (define -get-path-def get-path-def)
180 (define-method (set-path-def (this <gnome-canvas-shape>)
181 (def <gnome-canvas-path-def>))
182 (-set-path-def this (get-def def)))
184 (define-method (get-path-def (this <gnome-canvas-shape>))
185 (make <gnome-canvas-path-def> #:path-def (-get-path-def this)))))
187 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
188 ;;; stencil outputters
191 ;;; catch-all for missing stuff
192 ;;; comment this out to see find out what functions you miss :-)
193 (define (dummy . foo) #f)
194 (map (lambda (x) (module-define! this-module x dummy))
196 (ly:all-stencil-expressions)
197 (ly:all-output-backend-commands)))
199 (define (beam width slope thick blot)
200 (define cursor '(0 . 0))
201 (define (rmoveto def x y)
202 (set! cursor (cons (+ x (car cursor)) (+ y (cdr cursor))))
203 (moveto def (car cursor) (cdr cursor)))
204 (define (rlineto def x y)
205 (set! cursor (cons (+ x (car cursor)) (+ y (cdr cursor))))
206 (lineto def (car cursor) (cdr cursor)))
207 (let* ((def (make <gnome-canvas-path-def>))
208 (bezier (make <gnome-canvas-bpath>
209 #:parent (canvas-root)
211 #:outline-color "black"
213 #:join-style 'round))
219 (rmoveto def (/ blot 2) (/ t 2))
220 (rlineto def w (- h))
221 (rlineto def 0 (- t))
222 (rlineto def (- w) h)
225 (set-path-def bezier def)
228 (define (square-beam width slope thick blot)
229 (let* ((def (make <gnome-canvas-path-def>))
230 (y (* (- width) slope))
231 (props (make <gnome-canvas-bpath>
232 #:parent (canvas-root)
234 #:outline-color "black"
240 (lineto def width (- y thick))
241 (lineto def 0 (- thick))
244 (set-path-def props def)
248 (define (bezier-sandwich lst thick)
249 (let* ((def (make <gnome-canvas-path-def>))
250 (bezier (make <gnome-canvas-bpath>
251 #:parent (canvas-root)
253 #:outline-color "black"
255 #:join-style 'round)))
259 ;; FIXME: LST is pre-mangled for direct ps stack usage
263 (moveto def (car (list-ref lst 3)) (- (cdr (list-ref lst 3))))
264 (curveto def (car (list-ref lst 0)) (- (cdr (list-ref lst 0)))
265 (car (list-ref lst 1)) (- (cdr (list-ref lst 1)))
266 (car (list-ref lst 2)) (- (cdr (list-ref lst 2))))
268 (lineto def (car (list-ref lst 7)) (- (cdr (list-ref lst 7))))
269 (curveto def (car (list-ref lst 4)) (- (cdr (list-ref lst 4)))
270 (car (list-ref lst 5)) (- (cdr (list-ref lst 5)))
271 (car (list-ref lst 6)) (- (cdr (list-ref lst 6))))
272 (lineto def (car (list-ref lst 3)) (- (cdr (list-ref lst 3))))
275 (set-path-def bezier def)
278 (define (char font i)
279 (text font (ly:font-index-to-charcode font i)))
281 (define (dashed-line thick on off dx dy)
282 (draw-line thick 0 0 dx dy))
284 (define (draw-line thick x1 y1 x2 y2)
285 (let* ((def (make <gnome-canvas-path-def>))
286 (props (make <gnome-canvas-bpath>
287 #:parent (canvas-root)
289 #:outline-color "black"
290 #:width-units thick)))
292 (moveto def x1 (- y1))
293 (lineto def x2 (- y2))
294 (set-path-def props def)
298 (define (filledbox breapth width depth height)
299 (make <gnome-canvas-rect>
300 #:parent (canvas-root)
301 #:x1 (- breapth) #:y1 depth #:x2 width #:y2 (- height)
303 #:join-style 'miter))
305 ;; FIXME: the framework-gnome backend needs to see every item that
306 ;; gets created. All items created here must should be put in a group
307 ;; that gets returned.
308 (define (glyph-string font postscript-font-name x-y-named-glyphs)
312 ;; UGR, glyph names not found
313 (stderr "GLYPH:~S\n" (caddr x))
314 (stderr "ID:~S\n" (ly:font-glyph-name-to-charcode font (caddr x)))
315 (placebox (car x) (cadr x)
316 (make <gnome-canvas-text>
317 #:parent (canvas-root)
318 ;;#:x 0.0 #:y (if (music-font? font) 0.15 0.69)
321 #:font (pango-font-name font)
322 #:size-points (canvas-font-size font)
325 (integer->utf8-string
326 (ly:font-glyph-name-to-charcode font (caddr x))))))
329 (define (grob-cause offset grob)
332 ;; WTF is this in every backend?
333 (define (horizontal-line x1 x2 thickness)
334 (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness)))
336 (define (named-glyph font name)
337 (text font (ly:font-glyph-name-to-charcode font name)))
339 (define (placebox x y expr)
342 ;; FIXME ugly hack to skip #unspecified ...
343 (if (and item (not (eq? item (if #f #f))))
345 (move item (* output-scale x) (* output-scale (- y)))
346 (affine-relative item output-scale 0 0 output-scale 0 0)
350 (define (polygon coords blot-diameter)
351 (let* ((def (make <gnome-canvas-path-def>))
352 (props (make <gnome-canvas-bpath>
353 #:parent (canvas-root)
355 #:outline-color "black"
357 #:width-units blot-diameter)
358 (points (ly:list->offsets '() coords))
359 (last-point (car (last-pair points))))
362 (moveto def (car last-point) (cdr last-point))
363 (for-each (lambda (x) (lineto def (car x) (cdr x))) points)
365 (set-path-def props def)
368 (define (round-filled-box breapth width depth height blot-diameter)
369 (let ((r (/ blot-diameter 2)))
370 (make <gnome-canvas-rect>
371 #:parent (canvas-root)
372 #:x1 (- r breapth) #:y1 (- depth r) #:x2 (- width r) #:y2 (- r height)
374 #:outline-color "black"
375 #:width-units blot-diameter
376 #:join-style 'round)))
378 (define (text font s)
379 (make <gnome-canvas-text>
380 #:parent (canvas-root)
382 #:x 0.0 #:y (if (music-font? font) 0.15 0.69)
383 #:anchor (if (music-font? font) 'west 'south-west)
384 #:font (pango-font-name font)
385 #:size-points (canvas-font-size font)
387 #:text (if (integer? s)
388 (integer->utf8-string s)
389 (string->utf8-string s))))
391 (define (utf8-string pango-font-description string)
392 (make <gnome-canvas-text>
393 #:parent (canvas-root)
396 #:font pango-font-description
397 #:size-points (canvas-font-size pango-font-description)