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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
105 (define (stderr string . rest)
106 (apply format (cons (current-error-port) (cons string rest)))
107 (force-output (current-error-port)))
112 ((< i #x80) (list (integer->char i)))
113 ((< i #x800) (map integer->char
114 (list (+ #xc0 (quotient i #x40))
115 (+ #x80 (modulo i #x40)))))
117 (let ((x (quotient i #x1000))
118 (y (modulo i #x1000)))
121 (+ #x80 (quotient y #x40))
122 (+ #x80 (modulo y #x40))))))
123 (else (begin (stderr "programming-error: utf8 too big:~x\n" i)
124 (list (integer->char 32))))))
126 (define (integer->utf8-string integer)
127 (list->string (utf8 integer)))
129 (define (char->utf8-string char)
130 (list->string (utf8 (char->integer char))))
132 (define (string->utf8-string string)
135 (map (lambda (x) (char->utf8-string x)) (string->list string))))
137 (define (music-font? font)
138 (let ((family (car (font-name-style font))))
139 (string=? (substring family 0 (min (string-length family) 10))
142 ;;; FONT may be font smob, or pango font string
143 (define (pango-font-name font)
145 (list font "Regular")
146 (apply format (append '(#f "~a, ~a") (font-name-style font)))))
148 ;;; FONT may be font smob, or pango font string
149 (define (canvas-font-size font)
154 (* output-scale (modified-font-metric-font-scaling font)))))
156 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
157 ;;; Wrappers from guile-gnome TLA
158 ;;; guile-gnome-devel@gnu.org--2004
159 ;;; http://arch.gna.org/guile-gnome/archive-2004
161 ;;; janneke@gnu.org--2004-gnome
162 ;;; http://lilypond.org/~janneke/{arch}/2004-gnome
164 (if (not (defined? '<gnome-canvas-path-def>))
166 (define-class <gnome-canvas-path-def> (<gobject>)
167 (closure #:init-value (gnome-canvas-path-def-new)
168 #:init-keyword #:path-def
169 #:getter get-def #:setter set-def))
171 (define-method (moveto (this <gnome-canvas-path-def>) x y)
172 (gnome-canvas-path-def-moveto (get-def this) x y))
173 (define-method (curveto (this <gnome-canvas-path-def>) x1 y1 x2 y2 x3 y3)
174 (gnome-canvas-path-def-curveto (get-def this) x1 y1 x2 y2 x3 y3))
175 (define-method (lineto (this <gnome-canvas-path-def>) x y)
176 (gnome-canvas-path-def-lineto (get-def this) x y))
177 (define-method (closepath (this <gnome-canvas-path-def>))
178 (gnome-canvas-path-def-closepath (get-def this)))
179 (define-method (reset (this <gnome-canvas-path-def>))
180 (gnome-canvas-path-def-reset (get-def this)))
182 (define -set-path-def set-path-def)
183 (define -get-path-def get-path-def)
185 (define-method (set-path-def (this <gnome-canvas-shape>)
186 (def <gnome-canvas-path-def>))
187 (-set-path-def this (get-def def)))
189 (define-method (get-path-def (this <gnome-canvas-shape>))
190 (make <gnome-canvas-path-def> #:path-def (-get-path-def this)))))
192 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
193 ;;; stencil outputters
196 ;;; catch-all for missing stuff
197 ;;; comment this out to see find out what functions you miss :-)
198 (define (dummy . foo) #f)
199 (map (lambda (x) (module-define! this-module x dummy))
201 (ly:all-stencil-expressions)
202 (ly:all-output-backend-commands)))
204 (define (beam width slope thick blot)
205 (define cursor '(0 . 0))
206 (define (rmoveto def x y)
207 (set! cursor (cons (+ x (car cursor)) (+ y (cdr cursor))))
208 (moveto def (car cursor) (cdr cursor)))
209 (define (rlineto def x y)
210 (set! cursor (cons (+ x (car cursor)) (+ y (cdr cursor))))
211 (lineto def (car cursor) (cdr cursor)))
212 (let* ((def (make <gnome-canvas-path-def>))
213 (bezier (make <gnome-canvas-bpath>
214 #:parent (canvas-root)
216 #:outline-color "black"
218 #:join-style 'round))
224 (rmoveto def (/ blot 2) (/ t 2))
225 (rlineto def w (- h))
226 (rlineto def 0 (- t))
227 (rlineto def (- w) h)
230 (set-path-def bezier def)
233 (define (square-beam width slope thick blot)
234 (let* ((def (make <gnome-canvas-path-def>))
235 (y (* (- width) slope))
236 (props (make <gnome-canvas-bpath>
237 #:parent (canvas-root)
239 #:outline-color "black"
245 (lineto def width (- y thick))
246 (lineto def 0 (- thick))
249 (set-path-def props def)
253 (define (bezier-sandwich lst thick)
254 (let* ((def (make <gnome-canvas-path-def>))
255 (bezier (make <gnome-canvas-bpath>
256 #:parent (canvas-root)
258 #:outline-color "black"
260 #:join-style 'round)))
264 ;; FIXME: LST is pre-mangled for direct ps stack usage
268 (moveto def (car (list-ref lst 3)) (- (cdr (list-ref lst 3))))
269 (curveto def (car (list-ref lst 0)) (- (cdr (list-ref lst 0)))
270 (car (list-ref lst 1)) (- (cdr (list-ref lst 1)))
271 (car (list-ref lst 2)) (- (cdr (list-ref lst 2))))
273 (lineto def (car (list-ref lst 7)) (- (cdr (list-ref lst 7))))
274 (curveto def (car (list-ref lst 4)) (- (cdr (list-ref lst 4)))
275 (car (list-ref lst 5)) (- (cdr (list-ref lst 5)))
276 (car (list-ref lst 6)) (- (cdr (list-ref lst 6))))
277 (lineto def (car (list-ref lst 3)) (- (cdr (list-ref lst 3))))
280 (set-path-def bezier def)
283 (define (char font i)
284 (text font (ly:font-index-to-charcode font i)))
286 (define (dashed-line thick on off dx dy)
287 (draw-line thick 0 0 dx dy))
289 (define (draw-line thick x1 y1 x2 y2)
290 (let* ((def (make <gnome-canvas-path-def>))
291 (props (make <gnome-canvas-bpath>
292 #:parent (canvas-root)
294 #:outline-color "black"
295 #:width-units thick)))
297 (moveto def x1 (- y1))
298 (lineto def x2 (- y2))
299 (set-path-def props def)
303 (define (filledbox breapth width depth height)
304 (make <gnome-canvas-rect>
305 #:parent (canvas-root)
306 #:x1 (- breapth) #:y1 depth #:x2 width #:y2 (- height)
308 #:join-style 'miter))
310 ;; FIXME: the framework-gnome backend needs to see every item that
311 ;; gets created. All items created here must should be put in a group
312 ;; that gets returned.
313 (define (glyph-string font postscript-font-name x-y-named-glyphs)
317 ;; UGR, glyph names not found
318 (stderr "GLYPH:~S\n" (caddr x))
319 (stderr "ID:~S\n" (ly:font-glyph-name-to-charcode font (caddr x)))
320 (placebox (car x) (cadr x)
321 (make <gnome-canvas-text>
322 #:parent (canvas-root)
323 ;;#:x 0.0 #:y (if (music-font? font) 0.15 0.69)
326 #:font (pango-font-name font)
327 #:size-points (canvas-font-size font)
330 (integer->utf8-string
331 (ly:font-glyph-name-to-charcode font (caddr x))))))
334 (define (grob-cause offset grob)
337 ;; WTF is this in every backend?
338 (define (horizontal-line x1 x2 thickness)
339 (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness)))
341 (define (named-glyph font name)
342 (text font (ly:font-glyph-name-to-charcode font name)))
344 (define (placebox x y expr)
347 ;; FIXME ugly hack to skip #unspecified ...
348 (if (and item (not (eq? item (if #f #f))))
350 (move item (* output-scale x) (* output-scale (- y)))
351 (affine-relative item output-scale 0 0 output-scale 0 0)
355 (define (polygon coords blot-diameter)
356 (let* ((def (make <gnome-canvas-path-def>))
357 (props (make <gnome-canvas-bpath>
358 #:parent (canvas-root)
360 #:outline-color "black"
362 #:width-units blot-diameter)
363 (points (ly:list->offsets '() coords))
364 (last-point (car (last-pair points))))
367 (moveto def (car last-point) (cdr last-point))
368 (for-each (lambda (x) (lineto def (car x) (cdr x))) points)
370 (set-path-def props def)
373 (define (round-filled-box breapth width depth height blot-diameter)
374 (let ((r (/ blot-diameter 2)))
375 (make <gnome-canvas-rect>
376 #:parent (canvas-root)
377 #:x1 (- r breapth) #:y1 (- depth r) #:x2 (- width r) #:y2 (- r height)
379 #:outline-color "black"
380 #:width-units blot-diameter
381 #:join-style 'round)))
383 (define (text font s)
384 (make <gnome-canvas-text>
385 #:parent (canvas-root)
387 #:x 0.0 #:y (if (music-font? font) 0.15 0.69)
388 #:anchor (if (music-font? font) 'west 'south-west)
389 #:font (pango-font-name font)
390 #:size-points (canvas-font-size font)
392 #:text (if (integer? s)
393 (integer->utf8-string s)
394 (string->utf8-string s))))
396 (define (utf8-string pango-font-description string)
397 (make <gnome-canvas-text>
398 #:parent (canvas-root)
401 #:font pango-font-description
402 #:size-points (canvas-font-size pango-font-description)