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 (define-module (scm output-gnome))
83 (define this-module (current-module))
93 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
96 ;;; set by framework-gnome.scm
97 (define canvas-root #f)
98 (define output-scale #f)
100 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
105 ((< i #x80) (list (integer->char i)))
106 ((< i #x800) (map integer->char
107 (list (+ #xc0 (quotient i #x40))
108 (+ #x80 (modulo i #x40)))))
110 (let ((x (quotient i #x1000))
111 (y (modulo i #x1000)))
114 (+ #x80 (quotient y #x40))
115 (+ #x80 (modulo y #x40))))))
116 (else (begin (stderr "programming-error: utf8 too big:~x\n" i)
117 (list (integer->char 32))))))
119 (define (integer->utf8-string integer)
120 (list->string (utf8 integer)))
122 (define (char->utf8-string char)
123 (list->string (utf8 (char->integer char))))
125 (define (string->utf8-string string)
128 (map (lambda (x) (char->utf8-string x)) (string->list string))))
130 (define (music-font? font)
131 (let ((family (car (font-name-style font))))
132 (string=? (substring family 0 (min (string-length family) 10))
135 ;;; FONT may be font smob, or pango font string
136 (define (pango-font-name font)
138 (list font "Regular")
139 (apply format (append '(#f "~a, ~a") (font-name-style font)))))
141 ;;; FONT may be font smob, or pango font string
142 (define (canvas-font-size font)
147 (* output-scale (modified-font-metric-font-scaling font)))))
149 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
150 ;;; Wrappers from guile-gnome TLA
151 ;;; guile-gnome-devel@gnu.org--2004
152 ;;; http://arch.gna.org/guile-gnome/archive-2004
154 ;;; janneke@gnu.org--2004-gnome
155 ;;; http://lilypond.org/~janneke/{arch}/2004-gnome
157 (if (not (defined? '<gnome-canvas-path-def>))
159 (define-class <gnome-canvas-path-def> (<gobject>)
160 (closure #:init-value (gnome-canvas-path-def-new)
161 #:init-keyword #:path-def
162 #:getter get-def #:setter set-def))
164 (define-method (moveto (this <gnome-canvas-path-def>) x y)
165 (gnome-canvas-path-def-moveto (get-def this) x y))
166 (define-method (curveto (this <gnome-canvas-path-def>) x1 y1 x2 y2 x3 y3)
167 (gnome-canvas-path-def-curveto (get-def this) x1 y1 x2 y2 x3 y3))
168 (define-method (lineto (this <gnome-canvas-path-def>) x y)
169 (gnome-canvas-path-def-lineto (get-def this) x y))
170 (define-method (closepath (this <gnome-canvas-path-def>))
171 (gnome-canvas-path-def-closepath (get-def this)))
172 (define-method (reset (this <gnome-canvas-path-def>))
173 (gnome-canvas-path-def-reset (get-def this)))
175 (define -set-path-def set-path-def)
176 (define -get-path-def get-path-def)
178 (define-method (set-path-def (this <gnome-canvas-shape>)
179 (def <gnome-canvas-path-def>))
180 (-set-path-def this (get-def def)))
182 (define-method (get-path-def (this <gnome-canvas-shape>))
183 (make <gnome-canvas-path-def> #:path-def (-get-path-def this)))))
185 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
186 ;;; stencil outputters
189 ;;; catch-all for missing stuff
190 ;;; comment this out to see find out what functions you miss :-)
191 (define (dummy . foo) #f)
192 (map (lambda (x) (module-define! this-module x dummy))
194 (ly:all-stencil-expressions)
195 (ly:all-output-backend-commands)))
197 (define (beam width slope thick blot)
198 (define cursor '(0 . 0))
199 (define (rmoveto def x y)
200 (set! cursor (cons (+ x (car cursor)) (+ y (cdr cursor))))
201 (moveto def (car cursor) (cdr cursor)))
202 (define (rlineto def x y)
203 (set! cursor (cons (+ x (car cursor)) (+ y (cdr cursor))))
204 (lineto def (car cursor) (cdr cursor)))
205 (let* ((def (make <gnome-canvas-path-def>))
206 (bezier (make <gnome-canvas-bpath>
207 #:parent (canvas-root)
209 #:outline-color "black"
211 #:join-style 'round))
217 (rmoveto def (/ blot 2) (/ t 2))
218 (rlineto def w (- h))
219 (rlineto def 0 (- t))
220 (rlineto def (- w) h)
223 (set-path-def bezier def)
226 (define (square-beam width slope thick blot)
227 (let* ((def (make <gnome-canvas-path-def>))
228 (y (* (- width) slope))
229 (props (make <gnome-canvas-bpath>
230 #:parent (canvas-root)
232 #:outline-color "black"
238 (lineto def width (- y thick))
239 (lineto def 0 (- thick))
242 (set-path-def props def)
246 (define (bezier-sandwich lst thick)
247 (let* ((def (make <gnome-canvas-path-def>))
248 (bezier (make <gnome-canvas-bpath>
249 #:parent (canvas-root)
251 #:outline-color "black"
253 #:join-style 'round)))
257 ;; FIXME: LST is pre-mangled for direct ps stack usage
261 (moveto def (car (list-ref lst 3)) (- (cdr (list-ref lst 3))))
262 (curveto def (car (list-ref lst 0)) (- (cdr (list-ref lst 0)))
263 (car (list-ref lst 1)) (- (cdr (list-ref lst 1)))
264 (car (list-ref lst 2)) (- (cdr (list-ref lst 2))))
266 (lineto def (car (list-ref lst 7)) (- (cdr (list-ref lst 7))))
267 (curveto def (car (list-ref lst 4)) (- (cdr (list-ref lst 4)))
268 (car (list-ref lst 5)) (- (cdr (list-ref lst 5)))
269 (car (list-ref lst 6)) (- (cdr (list-ref lst 6))))
270 (lineto def (car (list-ref lst 3)) (- (cdr (list-ref lst 3))))
273 (set-path-def bezier def)
276 (define (char font i)
277 (text font (ly:font-index-to-charcode font i)))
279 (define (dashed-line thick on off dx dy)
280 (draw-line thick 0 0 dx dy))
282 (define (draw-line thick x1 y1 x2 y2)
283 (let* ((def (make <gnome-canvas-path-def>))
284 (props (make <gnome-canvas-bpath>
285 #:parent (canvas-root)
287 #:outline-color "black"
288 #:width-units thick)))
290 (moveto def x1 (- y1))
291 (lineto def x2 (- y2))
292 (set-path-def props def)
296 (define (filledbox breapth width depth height)
297 (make <gnome-canvas-rect>
298 #:parent (canvas-root)
299 #:x1 (- breapth) #:y1 depth #:x2 width #:y2 (- height)
301 #:join-style 'miter))
303 ;; FIXME: the framework-gnome backend needs to see every item that
304 ;; gets created. All items created here must should be put in a group
305 ;; that gets returned.
306 (define (glyph-string font postscript-font-name x-y-named-glyphs)
310 ;; UGR, glyph names not found
311 (stderr "GLYPH:~S\n" (caddr x))
312 (stderr "ID:~S\n" (ly:font-glyph-name-to-charcode font (caddr x)))
313 (placebox (car x) (cadr x)
314 (make <gnome-canvas-text>
315 #:parent (canvas-root)
316 ;;#:x 0.0 #:y (if (music-font? font) 0.15 0.69)
319 #:font (pango-font-name font)
320 #:size-points (canvas-font-size font)
323 (integer->utf8-string
324 (ly:font-glyph-name-to-charcode font (caddr x))))))
327 (define (grob-cause offset grob)
331 (define (named-glyph font name)
332 (text font (ly:font-glyph-name-to-charcode font name)))
334 (define (placebox x y expr)
337 ;; FIXME ugly hack to skip #unspecified ...
338 (if (and item (not (eq? item (if #f #f))))
340 (move item (* output-scale x) (* output-scale (- y)))
341 (affine-relative item output-scale 0 0 output-scale 0 0)
345 (define (polygon coords blot-diameter)
346 (let* ((def (make <gnome-canvas-path-def>))
347 (props (make <gnome-canvas-bpath>
348 #:parent (canvas-root)
350 #:outline-color "black"
352 #:width-units blot-diameter)
353 (points (ly:list->offsets '() coords))
354 (last-point (car (last-pair points))))
357 (moveto def (car last-point) (cdr last-point))
358 (for-each (lambda (x) (lineto def (car x) (cdr x))) points)
360 (set-path-def props def)
363 (define (round-filled-box breapth width depth height blot-diameter)
364 (let ((r (/ blot-diameter 2)))
365 (make <gnome-canvas-rect>
366 #:parent (canvas-root)
367 #:x1 (- r breapth) #:y1 (- depth r) #:x2 (- width r) #:y2 (- r height)
369 #:outline-color "black"
370 #:width-units blot-diameter
371 #:join-style 'round)))
373 (define (text font s)
374 (make <gnome-canvas-text>
375 #:parent (canvas-root)
377 #:x 0.0 #:y (if (music-font? font) 0.15 0.69)
378 #:anchor (if (music-font? font) 'west 'south-west)
379 #:font (pango-font-name font)
380 #:size-points (canvas-font-size font)
382 #:text (if (integer? s)
383 (integer->utf8-string s)
384 (string->utf8-string s))))
386 (define (utf8-string pango-font-description string)
387 (make <gnome-canvas-text>
388 #:parent (canvas-root)
391 #:font pango-font-description
392 #:size-points (canvas-font-size pango-font-description)